toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *  'It all comes from here, the stench and the peril.'    --Frodo
  13  *
  14  *     [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
  15  */
  16
  17 /*
  18  * This file is the lexer for Perl.  It's closely linked to the
  19  * parser, perly.y.
  20  *
  21  * The main routine is yylex(), which returns the next token.
  22  */
  23
  24 #include "EXTERN.h"
  25 #define PERL_IN_TOKE_C
  26 #include "perl.h"
  27
  28 #define new_constant(a,b,c,d,e,f,g)     \
  29         S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
  30
  31 #define pl_yylval       (PL_parser->yylval)
  32
  33 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  34 #define YYINITDEPTH 200
  35
  36 /* XXX temporary backwards compatibility */
  37 #define PL_lex_brackets         (PL_parser->lex_brackets)
  38 #define PL_lex_brackstack       (PL_parser->lex_brackstack)
  39 #define PL_lex_casemods         (PL_parser->lex_casemods)
  40 #define PL_lex_casestack        (PL_parser->lex_casestack)
  41 #define PL_lex_defer            (PL_parser->lex_defer)
  42 #define PL_lex_dojoin           (PL_parser->lex_dojoin)
  43 #define PL_lex_expect           (PL_parser->lex_expect)
  44 #define PL_lex_formbrack        (PL_parser->lex_formbrack)
  45 #define PL_lex_inpat            (PL_parser->lex_inpat)
  46 #define PL_lex_inwhat           (PL_parser->lex_inwhat)
  47 #define PL_lex_op               (PL_parser->lex_op)
  48 #define PL_lex_repl             (PL_parser->lex_repl)
  49 #define PL_lex_starts           (PL_parser->lex_starts)
  50 #define PL_lex_stuff            (PL_parser->lex_stuff)
  51 #define PL_multi_start          (PL_parser->multi_start)
  52 #define PL_multi_open           (PL_parser->multi_open)
  53 #define PL_multi_close          (PL_parser->multi_close)
  54 #define PL_pending_ident        (PL_parser->pending_ident)
  55 #define PL_preambled            (PL_parser->preambled)
  56 #define PL_sublex_info          (PL_parser->sublex_info)
  57 #define PL_linestr              (PL_parser->linestr)
  58 #define PL_expect               (PL_parser->expect)
  59 #define PL_copline              (PL_parser->copline)
  60 #define PL_bufptr               (PL_parser->bufptr)
  61 #define PL_oldbufptr            (PL_parser->oldbufptr)
  62 #define PL_oldoldbufptr         (PL_parser->oldoldbufptr)
  63 #define PL_linestart            (PL_parser->linestart)
  64 #define PL_bufend               (PL_parser->bufend)
  65 #define PL_last_uni             (PL_parser->last_uni)
  66 #define PL_last_lop             (PL_parser->last_lop)
  67 #define PL_last_lop_op          (PL_parser->last_lop_op)
  68 #define PL_lex_state            (PL_parser->lex_state)
  69 #define PL_rsfp                 (PL_parser->rsfp)
  70 #define PL_rsfp_filters         (PL_parser->rsfp_filters)
  71 #define PL_in_my                (PL_parser->in_my)
  72 #define PL_in_my_stash          (PL_parser->in_my_stash)
  73 #define PL_tokenbuf             (PL_parser->tokenbuf)
  74 #define PL_multi_end            (PL_parser->multi_end)
  75 #define PL_error_count          (PL_parser->error_count)
  76
  77 #ifdef PERL_MAD
  78 #  define PL_endwhite           (PL_parser->endwhite)
  79 #  define PL_faketokens         (PL_parser->faketokens)
  80 #  define PL_lasttoke           (PL_parser->lasttoke)
  81 #  define PL_nextwhite          (PL_parser->nextwhite)
  82 #  define PL_realtokenstart     (PL_parser->realtokenstart)
  83 #  define PL_skipwhite          (PL_parser->skipwhite)
  84 #  define PL_thisclose          (PL_parser->thisclose)
  85 #  define PL_thismad            (PL_parser->thismad)
  86 #  define PL_thisopen           (PL_parser->thisopen)
  87 #  define PL_thisstuff          (PL_parser->thisstuff)
  88 #  define PL_thistoken          (PL_parser->thistoken)
  89 #  define PL_thiswhite          (PL_parser->thiswhite)
  90 #  define PL_thiswhite          (PL_parser->thiswhite)
  91 #  define PL_nexttoke           (PL_parser->nexttoke)
  92 #  define PL_curforce           (PL_parser->curforce)
  93 #else
  94 #  define PL_nexttoke           (PL_parser->nexttoke)
  95 #  define PL_nexttype           (PL_parser->nexttype)
  96 #  define PL_nextval            (PL_parser->nextval)
  97 #endif
  98
  99 static int
 100 S_pending_ident(pTHX);
 101
 102 static const char ident_too_long[] = "Identifier too long";
 103 static const char commaless_variable_list[] = "comma-less variable list";
 104
 105 #ifndef PERL_NO_UTF16_FILTER
 106 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 107 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 108 #endif
 109
 110 #ifdef PERL_MAD
 111 #  define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
 112 #  define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
 113 #else
 114 #  define CURMAD(slot,sv)
 115 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
 116 #endif
 117
 118 #define XFAKEBRACK 128
 119 #define XENUMMASK 127
 120
 121 #ifdef USE_UTF8_SCRIPTS
 122 #   define UTF (!IN_BYTES)
 123 #else
 124 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
 125 #endif
 126
 127 /* In variables named $^X, these are the legal values for X.
 128  * 1999-02-27 mjd-perl-patch@plover.com */
 129 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
 130
 131 /* On MacOS, respect nonbreaking spaces */
 132 #ifdef MACOS_TRADITIONAL
 133 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
 134 #else
 135 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
 136 #endif
 137
 138 /* LEX_* are values for PL_lex_state, the state of the lexer.
 139  * They are arranged oddly so that the guard on the switch statement
 140  * can get by with a single comparison (if the compiler is smart enough).
 141  */
 142
 143 /* #define LEX_NOTPARSING               11 is done in perl.h. */
 144
 145 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
 146 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
 147 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
 148 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
 149 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
 150
 151                                    /* at end of code, eg "$x" followed by:  */
 152 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
 153 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
 154
 155 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
 156                                         string or after \E, $foo, etc       */
 157 #define LEX_INTERPCONST          2 /* NOT USED */
 158 #define LEX_FORMLINE             1 /* expecting a format line               */
 159 #define LEX_KNOWNEXT             0 /* next token known; just return it      */
 160
 161
 162 #ifdef DEBUGGING
 163 static const char* const lex_state_names[] = {
 164     "KNOWNEXT",
 165     "FORMLINE",
 166     "INTERPCONST",
 167     "INTERPCONCAT",
 168     "INTERPENDMAYBE",
 169     "INTERPEND",
 170     "INTERPSTART",
 171     "INTERPPUSH",
 172     "INTERPCASEMOD",
 173     "INTERPNORMAL",
 174     "NORMAL"
 175 };
 176 #endif
 177
 178 #ifdef ff_next
 179 #undef ff_next
 180 #endif
 181
 182 #include "keywords.h"
 183
 184 /* CLINE is a macro that ensures PL_copline has a sane value */
 185
 186 #ifdef CLINE
 187 #undef CLINE
 188 #endif
 189 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 190
 191 #ifdef PERL_MAD
 192 #  define SKIPSPACE0(s) skipspace0(s)
 193 #  define SKIPSPACE1(s) skipspace1(s)
 194 #  define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
 195 #  define PEEKSPACE(s) skipspace2(s,0)
 196 #else
 197 #  define SKIPSPACE0(s) skipspace(s)
 198 #  define SKIPSPACE1(s) skipspace(s)
 199 #  define SKIPSPACE2(s,tsv) skipspace(s)
 200 #  define PEEKSPACE(s) skipspace(s)
 201 #endif
 202
 203 /*
 204  * Convenience functions to return different tokens and prime the
 205  * lexer for the next token.  They all take an argument.
 206  *
 207  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 208  * OPERATOR     : generic operator
 209  * AOPERATOR    : assignment operator
 210  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 211  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 212  * PREREF       : *EXPR where EXPR is not a simple identifier
 213  * TERM         : expression term
 214  * LOOPX        : loop exiting command (goto, last, dump, etc)
 215  * FTST         : file test operator
 216  * FUN0         : zero-argument function
 217  * FUN1         : not used, except for not, which isn't a UNIOP
 218  * BOop         : bitwise or or xor
 219  * BAop         : bitwise and
 220  * SHop         : shift operator
 221  * PWop         : power operator
 222  * PMop         : pattern-matching operator
 223  * Aop          : addition-level operator
 224  * Mop          : multiplication-level operator
 225  * Eop          : equality-testing operator
 226  * Rop          : relational operator <= != gt
 227  *
 228  * Also see LOP and lop() below.
 229  */
 230
 231 #ifdef DEBUGGING /* Serve -DT. */
 232 #   define REPORT(retval) tokereport((I32)retval, &pl_yylval)
 233 #else
 234 #   define REPORT(retval) (retval)
 235 #endif
 236
 237 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
 238 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
 239 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
 240 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
 241 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 242 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 243 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
 244 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 245 #define FTST(f)  return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 246 #define FUN0(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
 247 #define FUN1(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
 248 #define BOop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
 249 #define BAop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
 250 #define SHop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
 251 #define PWop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
 252 #define PMop(f)  return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
 253 #define Aop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
 254 #define Mop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
 255 #define Eop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
 256 #define Rop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
 257
 258 /* This bit of chicanery makes a unary function followed by
 259  * a parenthesis into a function with one argument, highest precedence.
 260  * The UNIDOR macro is for unary functions that can be followed by the //
 261  * operator (such as C<shift // 0>).
 262  */
 263 #define UNI2(f,x) { \
 264         pl_yylval.ival = f; \
 265         PL_expect = x; \
 266         PL_bufptr = s; \
 267         PL_last_uni = PL_oldbufptr; \
 268         PL_last_lop_op = f; \
 269         if (*s == '(') \
 270             return REPORT( (int)FUNC1 ); \
 271         s = PEEKSPACE(s); \
 272         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
 273         }
 274 #define UNI(f)    UNI2(f,XTERM)
 275 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 276
 277 #define UNIBRACK(f) { \
 278         pl_yylval.ival = f; \
 279         PL_bufptr = s; \
 280         PL_last_uni = PL_oldbufptr; \
 281         if (*s == '(') \
 282             return REPORT( (int)FUNC1 ); \
 283         s = PEEKSPACE(s); \
 284         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
 285         }
 286
 287 /* grandfather return to old style */
 288 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 289
 290 #ifdef DEBUGGING
 291
 292 /* how to interpret the pl_yylval associated with the token */
 293 enum token_type {
 294     TOKENTYPE_NONE,
 295     TOKENTYPE_IVAL,
 296     TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
 297     TOKENTYPE_PVAL,
 298     TOKENTYPE_OPVAL,
 299     TOKENTYPE_GVVAL
 300 };
 301
 302 static struct debug_tokens {
 303     const int token;
 304     enum token_type type;
 305     const char *name;
 306 } const debug_tokens[] =
 307 {
 308     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
 309     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
 310     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
 311     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
 312     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
 313     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
 314     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
 315     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
 316     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
 317     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
 318     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
 319     { DO,               TOKENTYPE_NONE,         "DO" },
 320     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
 321     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
 322     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
 323     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
 324     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
 325     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
 326     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
 327     { FOR,              TOKENTYPE_IVAL,         "FOR" },
 328     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
 329     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
 330     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
 331     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
 332     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
 333     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
 334     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
 335     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
 336     { IF,               TOKENTYPE_IVAL,         "IF" },
 337     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
 338     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
 339     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
 340     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
 341     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
 342     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
 343     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
 344     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
 345     { MY,               TOKENTYPE_IVAL,         "MY" },
 346     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
 347     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
 348     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
 349     { OROP,             TOKENTYPE_IVAL,         "OROP" },
 350     { OROR,             TOKENTYPE_NONE,         "OROR" },
 351     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
 352     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
 353     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
 354     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
 355     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
 356     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
 357     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
 358     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
 359     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
 360     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
 361     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
 362     { SUB,              TOKENTYPE_NONE,         "SUB" },
 363     { THING,            TOKENTYPE_OPVAL,        "THING" },
 364     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
 365     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
 366     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
 367     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
 368     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
 369     { USE,              TOKENTYPE_IVAL,         "USE" },
 370     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
 371     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
 372     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
 373     { YADAYADA,         TOKENTYPE_IVAL,         "YADAYADA" },
 374     { 0,                TOKENTYPE_NONE,         NULL }
 375 };
 376
 377 /* dump the returned token in rv, plus any optional arg in pl_yylval */
 378
 379 STATIC int
 380 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
 381 {
 382     dVAR;
 383
 384     PERL_ARGS_ASSERT_TOKEREPORT;
 385
 386     if (DEBUG_T_TEST) {
 387         const char *name = NULL;
 388         enum token_type type = TOKENTYPE_NONE;
 389         const struct debug_tokens *p;
 390         SV* const report = newSVpvs("<== ");
 391
 392         for (p = debug_tokens; p->token; p++) {
 393             if (p->token == (int)rv) {
 394                 name = p->name;
 395                 type = p->type;
 396                 break;
 397             }
 398         }
 399         if (name)
 400             Perl_sv_catpv(aTHX_ report, name);
 401         else if ((char)rv > ' ' && (char)rv < '~')
 402             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
 403         else if (!rv)
 404             sv_catpvs(report, "EOF");
 405         else
 406             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
 407         switch (type) {
 408         case TOKENTYPE_NONE:
 409         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
 410             break;
 411         case TOKENTYPE_IVAL:
 412             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
 413             break;
 414         case TOKENTYPE_OPNUM:
 415             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
 416                                     PL_op_name[lvalp->ival]);
 417             break;
 418         case TOKENTYPE_PVAL:
 419             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
 420             break;
 421         case TOKENTYPE_OPVAL:
 422             if (lvalp->opval) {
 423                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 424                                     PL_op_name[lvalp->opval->op_type]);
 425                 if (lvalp->opval->op_type == OP_CONST) {
 426                     Perl_sv_catpvf(aTHX_ report, " %s",
 427                         SvPEEK(cSVOPx_sv(lvalp->opval)));
 428                 }
 429
 430             }
 431             else
 432                 sv_catpvs(report, "(opval=null)");
 433             break;
 434         }
 435         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
 436     };
 437     return (int)rv;
 438 }
 439
 440
 441 /* print the buffer with suitable escapes */
 442
 443 STATIC void
 444 S_printbuf(pTHX_ const char *const fmt, const char *const s)
 445 {
 446     SV* const tmp = newSVpvs("");
 447
 448     PERL_ARGS_ASSERT_PRINTBUF;
 449
 450     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
 451     SvREFCNT_dec(tmp);
 452 }
 453
 454 #endif
 455
 456 /*
 457  * S_ao
 458  *
 459  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 460  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 461  */
 462
 463 STATIC int
 464 S_ao(pTHX_ int toketype)
 465 {
 466     dVAR;
 467     if (*PL_bufptr == '=') {
 468         PL_bufptr++;
 469         if (toketype == ANDAND)
 470             pl_yylval.ival = OP_ANDASSIGN;
 471         else if (toketype == OROR)
 472             pl_yylval.ival = OP_ORASSIGN;
 473         else if (toketype == DORDOR)
 474             pl_yylval.ival = OP_DORASSIGN;
 475         toketype = ASSIGNOP;
 476     }
 477     return toketype;
 478 }
 479
 480 /*
 481  * S_no_op
 482  * When Perl expects an operator and finds something else, no_op
 483  * prints the warning.  It always prints "<something> found where
 484  * operator expected.  It prints "Missing semicolon on previous line?"
 485  * if the surprise occurs at the start of the line.  "do you need to
 486  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 487  * where the compiler doesn't know if foo is a method call or a function.
 488  * It prints "Missing operator before end of line" if there's nothing
 489  * after the missing operator, or "... before <...>" if there is something
 490  * after the missing operator.
 491  */
 492
 493 STATIC void
 494 S_no_op(pTHX_ const char *const what, char *s)
 495 {
 496     dVAR;
 497     char * const oldbp = PL_bufptr;
 498     const bool is_first = (PL_oldbufptr == PL_linestart);
 499
 500     PERL_ARGS_ASSERT_NO_OP;
 501
 502     if (!s)
 503         s = oldbp;
 504     else
 505         PL_bufptr = s;
 506     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 507     if (ckWARN_d(WARN_SYNTAX)) {
 508         if (is_first)
 509             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 510                     "\t(Missing semicolon on previous line?)\n");
 511         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 512             const char *t;
 513             for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
 514                 NOOP;
 515             if (t < PL_bufptr && isSPACE(*t))
 516                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 517                         "\t(Do you need to predeclare %.*s?)\n",
 518                     (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 519         }
 520         else {
 521             assert(s >= oldbp);
 522             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 523                     "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 524         }
 525     }
 526     PL_bufptr = oldbp;
 527 }
 528
 529 /*
 530  * S_missingterm
 531  * Complain about missing quote/regexp/heredoc terminator.
 532  * If it's called with NULL then it cauterizes the line buffer.
 533  * If we're in a delimited string and the delimiter is a control
 534  * character, it's reformatted into a two-char sequence like ^C.
 535  * This is fatal.
 536  */
 537
 538 STATIC void
 539 S_missingterm(pTHX_ char *s)
 540 {
 541     dVAR;
 542     char tmpbuf[3];
 543     char q;
 544     if (s) {
 545         char * const nl = strrchr(s,'\n');
 546         if (nl)
 547             *nl = '\0';
 548     }
 549     else if (isCNTRL(PL_multi_close)) {
 550         *tmpbuf = '^';
 551         tmpbuf[1] = (char)toCTRL(PL_multi_close);
 552         tmpbuf[2] = '\0';
 553         s = tmpbuf;
 554     }
 555     else {
 556         *tmpbuf = (char)PL_multi_close;
 557         tmpbuf[1] = '\0';
 558         s = tmpbuf;
 559     }
 560     q = strchr(s,'"') ? '\'' : '"';
 561     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 562 }
 563
 564 #define FEATURE_IS_ENABLED(name)                                        \
 565         ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
 566             && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 567 /* The longest string we pass in.  */
 568 #define MAX_FEATURE_LEN (sizeof("switch")-1)
 569
 570 /*
 571  * S_feature_is_enabled
 572  * Check whether the named feature is enabled.
 573  */
 574 STATIC bool
 575 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
 576 {
 577     dVAR;
 578     HV * const hinthv = GvHV(PL_hintgv);
 579     char he_name[8 + MAX_FEATURE_LEN] = "feature_";
 580
 581     PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
 582
 583     assert(namelen <= MAX_FEATURE_LEN);
 584     memcpy(&he_name[8], name, namelen);
 585
 586     return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 587 }
 588
 589 /*
 590  * Perl_deprecate
 591  */
 592
 593 void
 594 Perl_deprecate(pTHX_ const char *const s)
 595 {
 596     PERL_ARGS_ASSERT_DEPRECATE;
 597
 598     if (ckWARN(WARN_DEPRECATED))
 599         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 600 }
 601
 602 void
 603 Perl_deprecate_old(pTHX_ const char *const s)
 604 {
 605     /* This function should NOT be called for any new deprecated warnings */
 606     /* Use Perl_deprecate instead                                         */
 607     /*                                                                    */
 608     /* It is here to maintain backward compatibility with the pre-5.8     */
 609     /* warnings category hierarchy. The "deprecated" category used to     */
 610     /* live under the "syntax" category. It is now a top-level category   */
 611     /* in its own right.                                                  */
 612
 613     PERL_ARGS_ASSERT_DEPRECATE_OLD;
 614
 615     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 616         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 617                         "Use of %s is deprecated", s);
 618 }
 619
 620 /*
 621  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 622  * utf16-to-utf8-reversed.
 623  */
 624
 625 #ifdef PERL_CR_FILTER
 626 static void
 627 strip_return(SV *sv)
 628 {
 629     register const char *s = SvPVX_const(sv);
 630     register const char * const e = s + SvCUR(sv);
 631
 632     PERL_ARGS_ASSERT_STRIP_RETURN;
 633
 634     /* outer loop optimized to do nothing if there are no CR-LFs */
 635     while (s < e) {
 636         if (*s++ == '\r' && *s == '\n') {
 637             /* hit a CR-LF, need to copy the rest */
 638             register char *d = s - 1;
 639             *d++ = *s++;
 640             while (s < e) {
 641                 if (*s == '\r' && s[1] == '\n')
 642                     s++;
 643                 *d++ = *s++;
 644             }
 645             SvCUR(sv) -= s - d;
 646             return;
 647         }
 648     }
 649 }
 650
 651 STATIC I32
 652 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 653 {
 654     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 655     if (count > 0 && !maxlen)
 656         strip_return(sv);
 657     return count;
 658 }
 659 #endif
 660
 661
 662
 663 /*
 664  * Perl_lex_start
 665  *
 666  * Create a parser object and initialise its parser and lexer fields
 667  *
 668  * rsfp       is the opened file handle to read from (if any),
 669  *
 670  * line       holds any initial content already read from the file (or in
 671  *            the case of no file, such as an eval, the whole contents);
 672  *
 673  * new_filter indicates that this is a new file and it shouldn't inherit
 674  *            the filters from the current parser (ie require).
 675  */
 676
 677 void
 678 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
 679 {
 680     dVAR;
 681     const char *s = NULL;
 682     STRLEN len;
 683     yy_parser *parser, *oparser;
 684
 685     /* create and initialise a parser */
 686
 687     Newxz(parser, 1, yy_parser);
 688     parser->old_parser = oparser = PL_parser;
 689     PL_parser = parser;
 690
 691     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 692     parser->ps = parser->stack;
 693     parser->stack_size = YYINITDEPTH;
 694
 695     parser->stack->state = 0;
 696     parser->yyerrstatus = 0;
 697     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
 698
 699     /* on scope exit, free this parser and restore any outer one */
 700     SAVEPARSER(parser);
 701     parser->saved_curcop = PL_curcop;
 702
 703     /* initialise lexer state */
 704
 705 #ifdef PERL_MAD
 706     parser->curforce = -1;
 707 #else
 708     parser->nexttoke = 0;
 709 #endif
 710     parser->error_count = oparser ? oparser->error_count : 0;
 711     parser->copline = NOLINE;
 712     parser->lex_state = LEX_NORMAL;
 713     parser->expect = XSTATE;
 714     parser->rsfp = rsfp;
 715     parser->rsfp_filters = (new_filter || !oparser) ? newAV()
 716                 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
 717
 718     Newx(parser->lex_brackstack, 120, char);
 719     Newx(parser->lex_casestack, 12, char);
 720     *parser->lex_casestack = '\0';
 721
 722     if (line) {
 723         s = SvPV_const(line, len);
 724     } else {
 725         len = 0;
 726     }
 727
 728     if (!len) {
 729         parser->linestr = newSVpvs("\n;");
 730     } else if (SvREADONLY(line) || s[len-1] != ';') {
 731         parser->linestr = newSVsv(line);
 732         if (s[len-1] != ';')
 733             sv_catpvs(parser->linestr, "\n;");
 734     } else {
 735         SvTEMP_off(line);
 736         SvREFCNT_inc_simple_void_NN(line);
 737         parser->linestr = line;
 738     }
 739     parser->oldoldbufptr =
 740         parser->oldbufptr =
 741         parser->bufptr =
 742         parser->linestart = SvPVX(parser->linestr);
 743     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
 744     parser->last_lop = parser->last_uni = NULL;
 745 }
 746
 747
 748 /* delete a parser object */
 749
 750 void
 751 Perl_parser_free(pTHX_  const yy_parser *parser)
 752 {
 753     PERL_ARGS_ASSERT_PARSER_FREE;
 754
 755     PL_curcop = parser->saved_curcop;
 756     SvREFCNT_dec(parser->linestr);
 757
 758     if (parser->rsfp == PerlIO_stdin())
 759         PerlIO_clearerr(parser->rsfp);
 760     else if (parser->rsfp && (!parser->old_parser ||
 761                 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
 762         PerlIO_close(parser->rsfp);
 763     SvREFCNT_dec(parser->rsfp_filters);
 764
 765     Safefree(parser->stack);
 766     Safefree(parser->lex_brackstack);
 767     Safefree(parser->lex_casestack);
 768     PL_parser = parser->old_parser;
 769     Safefree(parser);
 770 }
 771
 772
 773 /*
 774  * Perl_lex_end
 775  * Finalizer for lexing operations.  Must be called when the parser is
 776  * done with the lexer.
 777  */
 778
 779 void
 780 Perl_lex_end(pTHX)
 781 {
 782     dVAR;
 783     PL_doextract = FALSE;
 784 }
 785
 786 /*
 787  * S_incline
 788  * This subroutine has nothing to do with tilting, whether at windmills
 789  * or pinball tables.  Its name is short for "increment line".  It
 790  * increments the current line number in CopLINE(PL_curcop) and checks
 791  * to see whether the line starts with a comment of the form
 792  *    # line 500 "foo.pm"
 793  * If so, it sets the current line number and file to the values in the comment.
 794  */
 795
 796 STATIC void
 797 S_incline(pTHX_ const char *s)
 798 {
 799     dVAR;
 800     const char *t;
 801     const char *n;
 802     const char *e;
 803
 804     PERL_ARGS_ASSERT_INCLINE;
 805
 806     CopLINE_inc(PL_curcop);
 807     if (*s++ != '#')
 808         return;
 809     while (SPACE_OR_TAB(*s))
 810         s++;
 811     if (strnEQ(s, "line", 4))
 812         s += 4;
 813     else
 814         return;
 815     if (SPACE_OR_TAB(*s))
 816         s++;
 817     else
 818         return;
 819     while (SPACE_OR_TAB(*s))
 820         s++;
 821     if (!isDIGIT(*s))
 822         return;
 823
 824     n = s;
 825     while (isDIGIT(*s))
 826         s++;
 827     if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
 828         return;
 829     while (SPACE_OR_TAB(*s))
 830         s++;
 831     if (*s == '"' && (t = strchr(s+1, '"'))) {
 832         s++;
 833         e = t + 1;
 834     }
 835     else {
 836         t = s;
 837         while (!isSPACE(*t))
 838             t++;
 839         e = t;
 840     }
 841     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 842         e++;
 843     if (*e != '\n' && *e != '\0')
 844         return;         /* false alarm */
 845
 846     if (t - s > 0) {
 847         const STRLEN len = t - s;
 848 #ifndef USE_ITHREADS
 849         SV *const temp_sv = CopFILESV(PL_curcop);
 850         const char *cf;
 851         STRLEN tmplen;
 852
 853         if (temp_sv) {
 854             cf = SvPVX(temp_sv);
 855             tmplen = SvCUR(temp_sv);
 856         } else {
 857             cf = NULL;
 858             tmplen = 0;
 859         }
 860
 861         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 862             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 863              * to *{"::_<newfilename"} */
 864             /* However, the long form of evals is only turned on by the
 865                debugger - usually they're "(eval %lu)" */
 866             char smallbuf[128];
 867             char *tmpbuf;
 868             GV **gvp;
 869             STRLEN tmplen2 = len;
 870             if (tmplen + 2 <= sizeof smallbuf)
 871                 tmpbuf = smallbuf;
 872             else
 873                 Newx(tmpbuf, tmplen + 2, char);
 874             tmpbuf[0] = '_';
 875             tmpbuf[1] = '<';
 876             memcpy(tmpbuf + 2, cf, tmplen);
 877             tmplen += 2;
 878             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 879             if (gvp) {
 880                 char *tmpbuf2;
 881                 GV *gv2;
 882
 883                 if (tmplen2 + 2 <= sizeof smallbuf)
 884                     tmpbuf2 = smallbuf;
 885                 else
 886                     Newx(tmpbuf2, tmplen2 + 2, char);
 887
 888                 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
 889                     /* Either they malloc'd it, or we malloc'd it,
 890                        so no prefix is present in ours.  */
 891                     tmpbuf2[0] = '_';
 892                     tmpbuf2[1] = '<';
 893                 }
 894
 895                 memcpy(tmpbuf2 + 2, s, tmplen2);
 896                 tmplen2 += 2;
 897
 898                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 899                 if (!isGV(gv2)) {
 900                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 901                     /* adjust ${"::_<newfilename"} to store the new file name */
 902                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 903                     GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
 904                     GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
 905                 }
 906
 907                 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
 908             }
 909             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 910         }
 911 #endif
 912         CopFILE_free(PL_curcop);
 913         CopFILE_setn(PL_curcop, s, len);
 914     }
 915     CopLINE_set(PL_curcop, atoi(n)-1);
 916 }
 917
 918 #ifdef PERL_MAD
 919 /* skip space before PL_thistoken */
 920
 921 STATIC char *
 922 S_skipspace0(pTHX_ register char *s)
 923 {
 924     PERL_ARGS_ASSERT_SKIPSPACE0;
 925
 926     s = skipspace(s);
 927     if (!PL_madskills)
 928         return s;
 929     if (PL_skipwhite) {
 930         if (!PL_thiswhite)
 931             PL_thiswhite = newSVpvs("");
 932         sv_catsv(PL_thiswhite, PL_skipwhite);
 933         sv_free(PL_skipwhite);
 934         PL_skipwhite = 0;
 935     }
 936     PL_realtokenstart = s - SvPVX(PL_linestr);
 937     return s;
 938 }
 939
 940 /* skip space after PL_thistoken */
 941
 942 STATIC char *
 943 S_skipspace1(pTHX_ register char *s)
 944 {
 945     const char *start = s;
 946     I32 startoff = start - SvPVX(PL_linestr);
 947
 948     PERL_ARGS_ASSERT_SKIPSPACE1;
 949
 950     s = skipspace(s);
 951     if (!PL_madskills)
 952         return s;
 953     start = SvPVX(PL_linestr) + startoff;
 954     if (!PL_thistoken && PL_realtokenstart >= 0) {
 955         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 956         PL_thistoken = newSVpvn(tstart, start - tstart);
 957     }
 958     PL_realtokenstart = -1;
 959     if (PL_skipwhite) {
 960         if (!PL_nextwhite)
 961             PL_nextwhite = newSVpvs("");
 962         sv_catsv(PL_nextwhite, PL_skipwhite);
 963         sv_free(PL_skipwhite);
 964         PL_skipwhite = 0;
 965     }
 966     return s;
 967 }
 968
 969 STATIC char *
 970 S_skipspace2(pTHX_ register char *s, SV **svp)
 971 {
 972     char *start;
 973     const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 974     const I32 startoff = s - SvPVX(PL_linestr);
 975
 976     PERL_ARGS_ASSERT_SKIPSPACE2;
 977
 978     s = skipspace(s);
 979     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 980     if (!PL_madskills || !svp)
 981         return s;
 982     start = SvPVX(PL_linestr) + startoff;
 983     if (!PL_thistoken && PL_realtokenstart >= 0) {
 984         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 985         PL_thistoken = newSVpvn(tstart, start - tstart);
 986         PL_realtokenstart = -1;
 987     }
 988     if (PL_skipwhite) {
 989         if (!*svp)
 990             *svp = newSVpvs("");
 991         sv_setsv(*svp, PL_skipwhite);
 992         sv_free(PL_skipwhite);
 993         PL_skipwhite = 0;
 994     }
 995
 996     return s;
 997 }
 998 #endif
 999
1000 STATIC void
1001 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1002 {
1003     AV *av = CopFILEAVx(PL_curcop);
1004     if (av) {
1005         SV * const sv = newSV_type(SVt_PVMG);
1006         if (orig_sv)
1007             sv_setsv(sv, orig_sv);
1008         else
1009             sv_setpvn(sv, buf, len);
1010         (void)SvIOK_on(sv);
1011         SvIV_set(sv, 0);
1012         av_store(av, (I32)CopLINE(PL_curcop), sv);
1013     }
1014 }
1015
1016 /*
1017  * S_skipspace
1018  * Called to gobble the appropriate amount and type of whitespace.
1019  * Skips comments as well.
1020  */
1021
1022 STATIC char *
1023 S_skipspace(pTHX_ register char *s)
1024 {
1025     dVAR;
1026 #ifdef PERL_MAD
1027     int curoff;
1028     int startoff = s - SvPVX(PL_linestr);
1029
1030     PERL_ARGS_ASSERT_SKIPSPACE;
1031
1032     if (PL_skipwhite) {
1033         sv_free(PL_skipwhite);
1034         PL_skipwhite = 0;
1035     }
1036 #endif
1037     PERL_ARGS_ASSERT_SKIPSPACE;
1038
1039     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1040         while (s < PL_bufend && SPACE_OR_TAB(*s))
1041             s++;
1042 #ifdef PERL_MAD
1043         goto done;
1044 #else
1045         return s;
1046 #endif
1047     }
1048     for (;;) {
1049         STRLEN prevlen;
1050         SSize_t oldprevlen, oldoldprevlen;
1051         SSize_t oldloplen = 0, oldunilen = 0;
1052         while (s < PL_bufend && isSPACE(*s)) {
1053             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1054                 incline(s);
1055         }
1056
1057         /* comment */
1058         if (s < PL_bufend && *s == '#') {
1059             while (s < PL_bufend && *s != '\n')
1060                 s++;
1061             if (s < PL_bufend) {
1062                 s++;
1063                 if (PL_in_eval && !PL_rsfp) {
1064                     incline(s);
1065                     continue;
1066                 }
1067             }
1068         }
1069
1070         /* only continue to recharge the buffer if we're at the end
1071          * of the buffer, we're not reading from a source filter, and
1072          * we're in normal lexing mode
1073          */
1074         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1075                 PL_lex_state == LEX_FORMLINE)
1076 #ifdef PERL_MAD
1077             goto done;
1078 #else
1079             return s;
1080 #endif
1081
1082         /* try to recharge the buffer */
1083 #ifdef PERL_MAD
1084         curoff = s - SvPVX(PL_linestr);
1085 #endif
1086
1087         if ((s = filter_gets(PL_linestr, PL_rsfp,
1088                              (prevlen = SvCUR(PL_linestr)))) == NULL)
1089         {
1090 #ifdef PERL_MAD
1091             if (PL_madskills && curoff != startoff) {
1092                 if (!PL_skipwhite)
1093                     PL_skipwhite = newSVpvs("");
1094                 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1095                                         curoff - startoff);
1096             }
1097
1098             /* mustn't throw out old stuff yet if madpropping */
1099             SvCUR(PL_linestr) = curoff;
1100             s = SvPVX(PL_linestr) + curoff;
1101             *s = 0;
1102             if (curoff && s[-1] == '\n')
1103                 s[-1] = ' ';
1104 #endif
1105
1106             /* end of file.  Add on the -p or -n magic */
1107             /* XXX these shouldn't really be added here, can't set PL_faketokens */
1108             if (PL_minus_p) {
1109 #ifdef PERL_MAD
1110                 sv_catpvs(PL_linestr,
1111                          ";}continue{print or die qq(-p destination: $!\\n);}");
1112 #else
1113                 sv_setpvs(PL_linestr,
1114                          ";}continue{print or die qq(-p destination: $!\\n);}");
1115 #endif
1116                 PL_minus_n = PL_minus_p = 0;
1117             }
1118             else if (PL_minus_n) {
1119 #ifdef PERL_MAD
1120                 sv_catpvs(PL_linestr, ";}");
1121 #else
1122                 sv_setpvs(PL_linestr, ";}");
1123 #endif
1124                 PL_minus_n = 0;
1125             }
1126             else
1127 #ifdef PERL_MAD
1128                 sv_catpvs(PL_linestr,";");
1129 #else
1130                 sv_setpvs(PL_linestr,";");
1131 #endif
1132
1133             /* reset variables for next time we lex */
1134             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1135                 = SvPVX(PL_linestr)
1136 #ifdef PERL_MAD
1137                 + curoff
1138 #endif
1139                 ;
1140             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1141             PL_last_lop = PL_last_uni = NULL;
1142
1143             /* Close the filehandle.  Could be from
1144              * STDIN, or a regular file.  If we were reading code from
1145              * STDIN (because the commandline held no -e or filename)
1146              * then we don't close it, we reset it so the code can
1147              * read from STDIN too.
1148              */
1149
1150             if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1151                 PerlIO_clearerr(PL_rsfp);
1152             else
1153                 (void)PerlIO_close(PL_rsfp);
1154             PL_rsfp = NULL;
1155             return s;
1156         }
1157
1158         /* not at end of file, so we only read another line */
1159         /* make corresponding updates to old pointers, for yyerror() */
1160         oldprevlen = PL_oldbufptr - PL_bufend;
1161         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1162         if (PL_last_uni)
1163             oldunilen = PL_last_uni - PL_bufend;
1164         if (PL_last_lop)
1165             oldloplen = PL_last_lop - PL_bufend;
1166         PL_linestart = PL_bufptr = s + prevlen;
1167         PL_bufend = s + SvCUR(PL_linestr);
1168         s = PL_bufptr;
1169         PL_oldbufptr = s + oldprevlen;
1170         PL_oldoldbufptr = s + oldoldprevlen;
1171         if (PL_last_uni)
1172             PL_last_uni = s + oldunilen;
1173         if (PL_last_lop)
1174             PL_last_lop = s + oldloplen;
1175         incline(s);
1176
1177         /* debugger active and we're not compiling the debugger code,
1178          * so store the line into the debugger's array of lines
1179          */
1180         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1181             update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1182     }
1183
1184 #ifdef PERL_MAD
1185   done:
1186     if (PL_madskills) {
1187         if (!PL_skipwhite)
1188             PL_skipwhite = newSVpvs("");
1189         curoff = s - SvPVX(PL_linestr);
1190         if (curoff - startoff)
1191             sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1192                                 curoff - startoff);
1193     }
1194     return s;
1195 #endif
1196 }
1197
1198 /*
1199  * S_check_uni
1200  * Check the unary operators to ensure there's no ambiguity in how they're
1201  * used.  An ambiguous piece of code would be:
1202  *     rand + 5
1203  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1204  * the +5 is its argument.
1205  */
1206
1207 STATIC void
1208 S_check_uni(pTHX)
1209 {
1210     dVAR;
1211     const char *s;
1212     const char *t;
1213
1214     if (PL_oldoldbufptr != PL_last_uni)
1215         return;
1216     while (isSPACE(*PL_last_uni))
1217         PL_last_uni++;
1218     s = PL_last_uni;
1219     while (isALNUM_lazy_if(s,UTF) || *s == '-')
1220         s++;
1221     if ((t = strchr(s, '(')) && t < PL_bufptr)
1222         return;
1223
1224     if (ckWARN_d(WARN_AMBIGUOUS)){
1225         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1226                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1227                    (int)(s - PL_last_uni), PL_last_uni);
1228     }
1229 }
1230
1231 /*
1232  * LOP : macro to build a list operator.  Its behaviour has been replaced
1233  * with a subroutine, S_lop() for which LOP is just another name.
1234  */
1235
1236 #define LOP(f,x) return lop(f,x,s)
1237
1238 /*
1239  * S_lop
1240  * Build a list operator (or something that might be one).  The rules:
1241  *  - if we have a next token, then it's a list operator [why?]
1242  *  - if the next thing is an opening paren, then it's a function
1243  *  - else it's a list operator
1244  */
1245
1246 STATIC I32
1247 S_lop(pTHX_ I32 f, int x, char *s)
1248 {
1249     dVAR;
1250
1251     PERL_ARGS_ASSERT_LOP;
1252
1253     pl_yylval.ival = f;
1254     CLINE;
1255     PL_expect = x;
1256     PL_bufptr = s;
1257     PL_last_lop = PL_oldbufptr;
1258     PL_last_lop_op = (OPCODE)f;
1259 #ifdef PERL_MAD
1260     if (PL_lasttoke)
1261         return REPORT(LSTOP);
1262 #else
1263     if (PL_nexttoke)
1264         return REPORT(LSTOP);
1265 #endif
1266     if (*s == '(')
1267         return REPORT(FUNC);
1268     s = PEEKSPACE(s);
1269     if (*s == '(')
1270         return REPORT(FUNC);
1271     else
1272         return REPORT(LSTOP);
1273 }
1274
1275 #ifdef PERL_MAD
1276  /*
1277  * S_start_force
1278  * Sets up for an eventual force_next().  start_force(0) basically does
1279  * an unshift, while start_force(-1) does a push.  yylex removes items
1280  * on the "pop" end.
1281  */
1282
1283 STATIC void
1284 S_start_force(pTHX_ int where)
1285 {
1286     int i;
1287
1288     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
1289         where = PL_lasttoke;
1290     assert(PL_curforce < 0 || PL_curforce == where);
1291     if (PL_curforce != where) {
1292         for (i = PL_lasttoke; i > where; --i) {
1293             PL_nexttoke[i] = PL_nexttoke[i-1];
1294         }
1295         PL_lasttoke++;
1296     }
1297     if (PL_curforce < 0)        /* in case of duplicate start_force() */
1298         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1299     PL_curforce = where;
1300     if (PL_nextwhite) {
1301         if (PL_madskills)
1302             curmad('^', newSVpvs(""));
1303         CURMAD('_', PL_nextwhite);
1304     }
1305 }
1306
1307 STATIC void
1308 S_curmad(pTHX_ char slot, SV *sv)
1309 {
1310     MADPROP **where;
1311
1312     if (!sv)
1313         return;
1314     if (PL_curforce < 0)
1315         where = &PL_thismad;
1316     else
1317         where = &PL_nexttoke[PL_curforce].next_mad;
1318
1319     if (PL_faketokens)
1320         sv_setpvs(sv, "");
1321     else {
1322         if (!IN_BYTES) {
1323             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1324                 SvUTF8_on(sv);
1325             else if (PL_encoding) {
1326                 sv_recode_to_utf8(sv, PL_encoding);
1327             }
1328         }
1329     }
1330
1331     /* keep a slot open for the head of the list? */
1332     if (slot != '_' && *where && (*where)->mad_key == '^') {
1333         (*where)->mad_key = slot;
1334         sv_free(MUTABLE_SV(((*where)->mad_val)));
1335         (*where)->mad_val = (void*)sv;
1336     }
1337     else
1338         addmad(newMADsv(slot, sv), where, 0);
1339 }
1340 #else
1341 #  define start_force(where)    NOOP
1342 #  define curmad(slot, sv)      NOOP
1343 #endif
1344
1345 /*
1346  * S_force_next
1347  * When the lexer realizes it knows the next token (for instance,
1348  * it is reordering tokens for the parser) then it can call S_force_next
1349  * to know what token to return the next time the lexer is called.  Caller
1350  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1351  * and possibly PL_expect to ensure the lexer handles the token correctly.
1352  */
1353
1354 STATIC void
1355 S_force_next(pTHX_ I32 type)
1356 {
1357     dVAR;
1358 #ifdef DEBUGGING
1359     if (DEBUG_T_TEST) {
1360         PerlIO_printf(Perl_debug_log, "### forced token:\n");
1361         tokereport(type, &NEXTVAL_NEXTTOKE);
1362     }
1363 #endif
1364 #ifdef PERL_MAD
1365     if (PL_curforce < 0)
1366         start_force(PL_lasttoke);
1367     PL_nexttoke[PL_curforce].next_type = type;
1368     if (PL_lex_state != LEX_KNOWNEXT)
1369         PL_lex_defer = PL_lex_state;
1370     PL_lex_state = LEX_KNOWNEXT;
1371     PL_lex_expect = PL_expect;
1372     PL_curforce = -1;
1373 #else
1374     PL_nexttype[PL_nexttoke] = type;
1375     PL_nexttoke++;
1376     if (PL_lex_state != LEX_KNOWNEXT) {
1377         PL_lex_defer = PL_lex_state;
1378         PL_lex_expect = PL_expect;
1379         PL_lex_state = LEX_KNOWNEXT;
1380     }
1381 #endif
1382 }
1383
1384 STATIC SV *
1385 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1386 {
1387     dVAR;
1388     SV * const sv = newSVpvn_utf8(start, len,
1389                                   UTF && !IN_BYTES
1390                                   && is_utf8_string((const U8*)start, len));
1391     return sv;
1392 }
1393
1394 /*
1395  * S_force_word
1396  * When the lexer knows the next thing is a word (for instance, it has
1397  * just seen -> and it knows that the next char is a word char, then
1398  * it calls S_force_word to stick the next word into the PL_nexttoke/val
1399  * lookahead.
1400  *
1401  * Arguments:
1402  *   char *start : buffer position (must be within PL_linestr)
1403  *   int token   : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1404  *   int check_keyword : if true, Perl checks to make sure the word isn't
1405  *       a keyword (do this if the word is a label, e.g. goto FOO)
1406  *   int allow_pack : if true, : characters will also be allowed (require,
1407  *       use, etc. do this)
1408  *   int allow_initial_tick : used by the "sub" lexer only.
1409  */
1410
1411 STATIC char *
1412 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1413 {
1414     dVAR;
1415     register char *s;
1416     STRLEN len;
1417
1418     PERL_ARGS_ASSERT_FORCE_WORD;
1419
1420     start = SKIPSPACE1(start);
1421     s = start;
1422     if (isIDFIRST_lazy_if(s,UTF) ||
1423         (allow_pack && *s == ':') ||
1424         (allow_initial_tick && *s == '\'') )
1425     {
1426         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1427         if (check_keyword && keyword(PL_tokenbuf, len, 0))
1428             return start;
1429         start_force(PL_curforce);
1430         if (PL_madskills)
1431             curmad('X', newSVpvn(start,s-start));
1432         if (token == METHOD) {
1433             s = SKIPSPACE1(s);
1434             if (*s == '(')
1435                 PL_expect = XTERM;
1436             else {
1437                 PL_expect = XOPERATOR;
1438             }
1439         }
1440         if (PL_madskills)
1441             curmad('g', newSVpvs( "forced" ));
1442         NEXTVAL_NEXTTOKE.opval
1443             = (OP*)newSVOP(OP_CONST,0,
1444                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1445         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1446         force_next(token);
1447     }
1448     return s;
1449 }
1450
1451 /*
1452  * S_force_ident
1453  * Called when the lexer wants $foo *foo &foo etc, but the program
1454  * text only contains the "foo" portion.  The first argument is a pointer
1455  * to the "foo", and the second argument is the type symbol to prefix.
1456  * Forces the next token to be a "WORD".
1457  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1458  */
1459
1460 STATIC void
1461 S_force_ident(pTHX_ register const char *s, int kind)
1462 {
1463     dVAR;
1464
1465     PERL_ARGS_ASSERT_FORCE_IDENT;
1466
1467     if (*s) {
1468         const STRLEN len = strlen(s);
1469         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1470         start_force(PL_curforce);
1471         NEXTVAL_NEXTTOKE.opval = o;
1472         force_next(WORD);
1473         if (kind) {
1474             o->op_private = OPpCONST_ENTERED;
1475             /* XXX see note in pp_entereval() for why we forgo typo
1476                warnings if the symbol must be introduced in an eval.
1477                GSAR 96-10-12 */
1478             gv_fetchpvn_flags(s, len,
1479                               PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1480                               : GV_ADD,
1481                               kind == '$' ? SVt_PV :
1482                               kind == '@' ? SVt_PVAV :
1483                               kind == '%' ? SVt_PVHV :
1484                               SVt_PVGV
1485                               );
1486         }
1487     }
1488 }
1489
1490 NV
1491 Perl_str_to_version(pTHX_ SV *sv)
1492 {
1493     NV retval = 0.0;
1494     NV nshift = 1.0;
1495     STRLEN len;
1496     const char *start = SvPV_const(sv,len);
1497     const char * const end = start + len;
1498     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1499
1500     PERL_ARGS_ASSERT_STR_TO_VERSION;
1501
1502     while (start < end) {
1503         STRLEN skip;
1504         UV n;
1505         if (utf)
1506             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1507         else {
1508             n = *(U8*)start;
1509             skip = 1;
1510         }
1511         retval += ((NV)n)/nshift;
1512         start += skip;
1513         nshift *= 1000;
1514     }
1515     return retval;
1516 }
1517
1518 /*
1519  * S_force_version
1520  * Forces the next token to be a version number.
1521  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1522  * and if "guessing" is TRUE, then no new token is created (and the caller
1523  * must use an alternative parsing method).
1524  */
1525
1526 STATIC char *
1527 S_force_version(pTHX_ char *s, int guessing)
1528 {
1529     dVAR;
1530     OP *version = NULL;
1531     char *d;
1532 #ifdef PERL_MAD
1533     I32 startoff = s - SvPVX(PL_linestr);
1534 #endif
1535
1536     PERL_ARGS_ASSERT_FORCE_VERSION;
1537
1538     s = SKIPSPACE1(s);
1539
1540     d = s;
1541     if (*d == 'v')
1542         d++;
1543     if (isDIGIT(*d)) {
1544         while (isDIGIT(*d) || *d == '_' || *d == '.')
1545             d++;
1546 #ifdef PERL_MAD
1547         if (PL_madskills) {
1548             start_force(PL_curforce);
1549             curmad('X', newSVpvn(s,d-s));
1550         }
1551 #endif
1552         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1553             SV *ver;
1554             s = scan_num(s, &pl_yylval);
1555             version = pl_yylval.opval;
1556             ver = cSVOPx(version)->op_sv;
1557             if (SvPOK(ver) && !SvNIOK(ver)) {
1558                 SvUPGRADE(ver, SVt_PVNV);
1559                 SvNV_set(ver, str_to_version(ver));
1560                 SvNOK_on(ver);          /* hint that it is a version */
1561             }
1562         }
1563         else if (guessing) {
1564 #ifdef PERL_MAD
1565             if (PL_madskills) {
1566                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
1567                 PL_nextwhite = 0;
1568                 s = SvPVX(PL_linestr) + startoff;
1569             }
1570 #endif
1571             return s;
1572         }
1573     }
1574
1575 #ifdef PERL_MAD
1576     if (PL_madskills && !version) {
1577         sv_free(PL_nextwhite);  /* let next token collect whitespace */
1578         PL_nextwhite = 0;
1579         s = SvPVX(PL_linestr) + startoff;
1580     }
1581 #endif
1582     /* NOTE: The parser sees the package name and the VERSION swapped */
1583     start_force(PL_curforce);
1584     NEXTVAL_NEXTTOKE.opval = version;
1585     force_next(WORD);
1586
1587     return s;
1588 }
1589
1590 /*
1591  * S_tokeq
1592  * Tokenize a quoted string passed in as an SV.  It finds the next
1593  * chunk, up to end of string or a backslash.  It may make a new
1594  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1595  * turns \\ into \.
1596  */
1597
1598 STATIC SV *
1599 S_tokeq(pTHX_ SV *sv)
1600 {
1601     dVAR;
1602     register char *s;
1603     register char *send;
1604     register char *d;
1605     STRLEN len = 0;
1606     SV *pv = sv;
1607
1608     PERL_ARGS_ASSERT_TOKEQ;
1609
1610     if (!SvLEN(sv))
1611         goto finish;
1612
1613     s = SvPV_force(sv, len);
1614     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1615         goto finish;
1616     send = s + len;
1617     while (s < send && *s != '\\')
1618         s++;
1619     if (s == send)
1620         goto finish;
1621     d = s;
1622     if ( PL_hints & HINT_NEW_STRING ) {
1623         pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1624     }
1625     while (s < send) {
1626         if (*s == '\\') {
1627             if (s + 1 < send && (s[1] == '\\'))
1628                 s++;            /* all that, just for this */
1629         }
1630         *d++ = *s++;
1631     }
1632     *d = '\0';
1633     SvCUR_set(sv, d - SvPVX_const(sv));
1634   finish:
1635     if ( PL_hints & HINT_NEW_STRING )
1636        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1637     return sv;
1638 }
1639
1640 /*
1641  * Now come three functions related to double-quote context,
1642  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1643  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1644  * interact with PL_lex_state, and create fake ( ... ) argument lists
1645  * to handle functions and concatenation.
1646  * They assume that whoever calls them will be setting up a fake
1647  * join call, because each subthing puts a ',' after it.  This lets
1648  *   "lower \luPpEr"
1649  * become
1650  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1651  *
1652  * (I'm not sure whether the spurious commas at the end of lcfirst's
1653  * arguments and join's arguments are created or not).
1654  */
1655
1656 /*
1657  * S_sublex_start
1658  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1659  *
1660  * Pattern matching will set PL_lex_op to the pattern-matching op to
1661  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1662  *
1663  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1664  *
1665  * Everything else becomes a FUNC.
1666  *
1667  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1668  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1669  * call to S_sublex_push().
1670  */
1671
1672 STATIC I32
1673 S_sublex_start(pTHX)
1674 {
1675     dVAR;
1676     register const I32 op_type = pl_yylval.ival;
1677
1678     if (op_type == OP_NULL) {
1679         pl_yylval.opval = PL_lex_op;
1680         PL_lex_op = NULL;
1681         return THING;
1682     }
1683     if (op_type == OP_CONST || op_type == OP_READLINE) {
1684         SV *sv = tokeq(PL_lex_stuff);
1685
1686         if (SvTYPE(sv) == SVt_PVIV) {
1687             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1688             STRLEN len;
1689             const char * const p = SvPV_const(sv, len);
1690             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1691             SvREFCNT_dec(sv);
1692             sv = nsv;
1693         }
1694         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1695         PL_lex_stuff = NULL;
1696         /* Allow <FH> // "foo" */
1697         if (op_type == OP_READLINE)
1698             PL_expect = XTERMORDORDOR;
1699         return THING;
1700     }
1701     else if (op_type == OP_BACKTICK && PL_lex_op) {
1702         /* readpipe() vas overriden */
1703         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1704         pl_yylval.opval = PL_lex_op;
1705         PL_lex_op = NULL;
1706         PL_lex_stuff = NULL;
1707         return THING;
1708     }
1709
1710     PL_sublex_info.super_state = PL_lex_state;
1711     PL_sublex_info.sub_inwhat = (U16)op_type;
1712     PL_sublex_info.sub_op = PL_lex_op;
1713     PL_lex_state = LEX_INTERPPUSH;
1714
1715     PL_expect = XTERM;
1716     if (PL_lex_op) {
1717         pl_yylval.opval = PL_lex_op;
1718         PL_lex_op = NULL;
1719         return PMFUNC;
1720     }
1721     else
1722         return FUNC;
1723 }
1724
1725 /*
1726  * S_sublex_push
1727  * Create a new scope to save the lexing state.  The scope will be
1728  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1729  * to the uc, lc, etc. found before.
1730  * Sets PL_lex_state to LEX_INTERPCONCAT.
1731  */
1732
1733 STATIC I32
1734 S_sublex_push(pTHX)
1735 {
1736     dVAR;
1737     ENTER;
1738
1739     PL_lex_state = PL_sublex_info.super_state;
1740     SAVEBOOL(PL_lex_dojoin);
1741     SAVEI32(PL_lex_brackets);
1742     SAVEI32(PL_lex_casemods);
1743     SAVEI32(PL_lex_starts);
1744     SAVEI8(PL_lex_state);
1745     SAVEVPTR(PL_lex_inpat);
1746     SAVEI16(PL_lex_inwhat);
1747     SAVECOPLINE(PL_curcop);
1748     SAVEPPTR(PL_bufptr);
1749     SAVEPPTR(PL_bufend);
1750     SAVEPPTR(PL_oldbufptr);
1751     SAVEPPTR(PL_oldoldbufptr);
1752     SAVEPPTR(PL_last_lop);
1753     SAVEPPTR(PL_last_uni);
1754     SAVEPPTR(PL_linestart);
1755     SAVESPTR(PL_linestr);
1756     SAVEGENERICPV(PL_lex_brackstack);
1757     SAVEGENERICPV(PL_lex_casestack);
1758
1759     PL_linestr = PL_lex_stuff;
1760     PL_lex_stuff = NULL;
1761
1762     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1763         = SvPVX(PL_linestr);
1764     PL_bufend += SvCUR(PL_linestr);
1765     PL_last_lop = PL_last_uni = NULL;
1766     SAVEFREESV(PL_linestr);
1767
1768     PL_lex_dojoin = FALSE;
1769     PL_lex_brackets = 0;
1770     Newx(PL_lex_brackstack, 120, char);
1771     Newx(PL_lex_casestack, 12, char);
1772     PL_lex_casemods = 0;
1773     *PL_lex_casestack = '\0';
1774     PL_lex_starts = 0;
1775     PL_lex_state = LEX_INTERPCONCAT;
1776     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1777
1778     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1779     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1780         PL_lex_inpat = PL_sublex_info.sub_op;
1781     else
1782         PL_lex_inpat = NULL;
1783
1784     return '(';
1785 }
1786
1787 /*
1788  * S_sublex_done
1789  * Restores lexer state after a S_sublex_push.
1790  */
1791
1792 STATIC I32
1793 S_sublex_done(pTHX)
1794 {
1795     dVAR;
1796     if (!PL_lex_starts++) {
1797         SV * const sv = newSVpvs("");
1798         if (SvUTF8(PL_linestr))
1799             SvUTF8_on(sv);
1800         PL_expect = XOPERATOR;
1801         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1802         return THING;
1803     }
1804
1805     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1806         PL_lex_state = LEX_INTERPCASEMOD;
1807         return yylex();
1808     }
1809
1810     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1811     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1812         PL_linestr = PL_lex_repl;
1813         PL_lex_inpat = 0;
1814         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1815         PL_bufend += SvCUR(PL_linestr);
1816         PL_last_lop = PL_last_uni = NULL;
1817         SAVEFREESV(PL_linestr);
1818         PL_lex_dojoin = FALSE;
1819         PL_lex_brackets = 0;
1820         PL_lex_casemods = 0;
1821         *PL_lex_casestack = '\0';
1822         PL_lex_starts = 0;
1823         if (SvEVALED(PL_lex_repl)) {
1824             PL_lex_state = LEX_INTERPNORMAL;
1825             PL_lex_starts++;
1826             /*  we don't clear PL_lex_repl here, so that we can check later
1827                 whether this is an evalled subst; that means we rely on the
1828                 logic to ensure sublex_done() is called again only via the
1829                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1830         }
1831         else {
1832             PL_lex_state = LEX_INTERPCONCAT;
1833             PL_lex_repl = NULL;
1834         }
1835         return ',';
1836     }
1837     else {
1838 #ifdef PERL_MAD
1839         if (PL_madskills) {
1840             if (PL_thiswhite) {
1841                 if (!PL_endwhite)
1842                     PL_endwhite = newSVpvs("");
1843                 sv_catsv(PL_endwhite, PL_thiswhite);
1844                 PL_thiswhite = 0;
1845             }
1846             if (PL_thistoken)
1847                 sv_setpvs(PL_thistoken,"");
1848             else
1849                 PL_realtokenstart = -1;
1850         }
1851 #endif
1852         LEAVE;
1853         PL_bufend = SvPVX(PL_linestr);
1854         PL_bufend += SvCUR(PL_linestr);
1855         PL_expect = XOPERATOR;
1856         PL_sublex_info.sub_inwhat = 0;
1857         return ')';
1858     }
1859 }
1860
1861 /*
1862   scan_const
1863
1864   Extracts a pattern, double-quoted string, or transliteration.  This
1865   is terrifying code.
1866
1867   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1868   processing a pattern (PL_lex_inpat is true), a transliteration
1869   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1870
1871   Returns a pointer to the character scanned up to. If this is
1872   advanced from the start pointer supplied (i.e. if anything was
1873   successfully parsed), will leave an OP for the substring scanned
1874   in pl_yylval. Caller must intuit reason for not parsing further
1875   by looking at the next characters herself.
1876
1877   In patterns:
1878     backslashes:
1879       double-quoted style: \r and \n
1880       regexp special ones: \D \s
1881       constants: \x31
1882       backrefs: \1
1883       case and quoting: \U \Q \E
1884     stops on @ and $, but not for $ as tail anchor
1885
1886   In transliterations:
1887     characters are VERY literal, except for - not at the start or end
1888     of the string, which indicates a range. If the range is in bytes,
1889     scan_const expands the range to the full set of intermediate
1890     characters. If the range is in utf8, the hyphen is replaced with
1891     a certain range mark which will be handled by pmtrans() in op.c.
1892
1893   In double-quoted strings:
1894     backslashes:
1895       double-quoted style: \r and \n
1896       constants: \x31
1897       deprecated backrefs: \1 (in substitution replacements)
1898       case and quoting: \U \Q \E
1899     stops on @ and $
1900
1901   scan_const does *not* construct ops to handle interpolated strings.
1902   It stops processing as soon as it finds an embedded $ or @ variable
1903   and leaves it to the caller to work out what's going on.
1904
1905   embedded arrays (whether in pattern or not) could be:
1906       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1907
1908   $ in double-quoted strings must be the symbol of an embedded scalar.
1909
1910   $ in pattern could be $foo or could be tail anchor.  Assumption:
1911   it's a tail anchor if $ is the last thing in the string, or if it's
1912   followed by one of "()| \r\n\t"
1913
1914   \1 (backreferences) are turned into $1
1915
1916   The structure of the code is
1917       while (there's a character to process) {
1918           handle transliteration ranges
1919           skip regexp comments /(?#comment)/ and codes /(?{code})/
1920           skip #-initiated comments in //x patterns
1921           check for embedded arrays
1922           check for embedded scalars
1923           if (backslash) {
1924               leave intact backslashes from leaveit (below)
1925               deprecate \1 in substitution replacements
1926               handle string-changing backslashes \l \U \Q \E, etc.
1927               switch (what was escaped) {
1928                   handle \- in a transliteration (becomes a literal -)
1929                   handle \132 (octal characters)
1930                   handle \x15 and \x{1234} (hex characters)
1931                   handle \N{name} (named characters)
1932                   handle \cV (control characters)
1933                   handle printf-style backslashes (\f, \r, \n, etc)
1934               } (end switch)
1935               continue
1936           } (end if backslash)
1937           handle regular character
1938     } (end while character to read)
1939
1940 */
1941
1942 STATIC char *
1943 S_scan_const(pTHX_ char *start)
1944 {
1945     dVAR;
1946     register char *send = PL_bufend;            /* end of the constant */
1947     SV *sv = newSV(send - start);               /* sv for the constant.  See
1948                                                    note below on sizing. */
1949     register char *s = start;                   /* start of the constant */
1950     register char *d = SvPVX(sv);               /* destination for copies */
1951     bool dorange = FALSE;                       /* are we in a translit range? */
1952     bool didrange = FALSE;                      /* did we just finish a range? */
1953     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1954     I32  this_utf8 = UTF;                       /* Is the source string assumed
1955                                                    to be UTF8?  But, this can
1956                                                    show as true when the source
1957                                                    isn't utf8, as for example
1958                                                    when it is entirely composed
1959                                                    of hex constants */
1960
1961     /* Note on sizing:  The scanned constant is placed into sv, which is
1962      * initialized by newSV() assuming one byte of output for every byte of
1963      * input.  This routine expects newSV() to allocate an extra byte for a
1964      * trailing NUL, which this routine will append if it gets to the end of
1965      * the input.  There may be more bytes of input than output (eg., \N{LATIN
1966      * CAPITAL LETTER A}), or more output than input if the constant ends up
1967      * recoded to utf8, but each time a construct is found that might increase
1968      * the needed size, SvGROW() is called.  Its size parameter each time is
1969      * based on the best guess estimate at the time, namely the length used so
1970      * far, plus the length the current construct will occupy, plus room for
1971      * the trailing NUL, plus one byte for every input byte still unscanned */
1972
1973     UV uv;
1974 #ifdef EBCDIC
1975     UV literal_endpoint = 0;
1976     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1977 #endif
1978
1979     PERL_ARGS_ASSERT_SCAN_CONST;
1980
1981     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1982         /* If we are doing a trans and we know we want UTF8 set expectation */
1983         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1984         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1985     }
1986
1987
1988     while (s < send || dorange) {
1989         /* get transliterations out of the way (they're most literal) */
1990         if (PL_lex_inwhat == OP_TRANS) {
1991             /* expand a range A-Z to the full set of characters.  AIE! */
1992             if (dorange) {
1993                 I32 i;                          /* current expanded character */
1994                 I32 min;                        /* first character in range */
1995                 I32 max;                        /* last character in range */
1996
1997 #ifdef EBCDIC
1998                 UV uvmax = 0;
1999 #endif
2000
2001                 if (has_utf8
2002 #ifdef EBCDIC
2003                     && !native_range
2004 #endif
2005                     ) {
2006                     char * const c = (char*)utf8_hop((U8*)d, -1);
2007                     char *e = d++;
2008                     while (e-- > c)
2009                         *(e + 1) = *e;
2010                     *c = (char)UTF_TO_NATIVE(0xff);
2011                     /* mark the range as done, and continue */
2012                     dorange = FALSE;
2013                     didrange = TRUE;
2014                     continue;
2015                 }
2016
2017                 i = d - SvPVX_const(sv);                /* remember current offset */
2018 #ifdef EBCDIC
2019                 SvGROW(sv,
2020                        SvLEN(sv) + (has_utf8 ?
2021                                     (512 - UTF_CONTINUATION_MARK +
2022                                      UNISKIP(0x100))
2023                                     : 256));
2024                 /* How many two-byte within 0..255: 128 in UTF-8,
2025                  * 96 in UTF-8-mod. */
2026 #else
2027                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
2028 #endif
2029                 d = SvPVX(sv) + i;              /* refresh d after realloc */
2030 #ifdef EBCDIC
2031                 if (has_utf8) {
2032                     int j;
2033                     for (j = 0; j <= 1; j++) {
2034                         char * const c = (char*)utf8_hop((U8*)d, -1);
2035                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2036                         if (j)
2037                             min = (U8)uv;
2038                         else if (uv < 256)
2039                             max = (U8)uv;
2040                         else {
2041                             max = (U8)0xff; /* only to \xff */
2042                             uvmax = uv; /* \x{100} to uvmax */
2043                         }
2044                         d = c; /* eat endpoint chars */
2045                      }
2046                 }
2047                else {
2048 #endif
2049                    d -= 2;              /* eat the first char and the - */
2050                    min = (U8)*d;        /* first char in range */
2051                    max = (U8)d[1];      /* last char in range  */
2052 #ifdef EBCDIC
2053                }
2054 #endif
2055
2056                 if (min > max) {
2057                     Perl_croak(aTHX_
2058                                "Invalid range \"%c-%c\" in transliteration operator",
2059                                (char)min, (char)max);
2060                 }
2061
2062 #ifdef EBCDIC
2063                 if (literal_endpoint == 2 &&
2064                     ((isLOWER(min) && isLOWER(max)) ||
2065                      (isUPPER(min) && isUPPER(max)))) {
2066                     if (isLOWER(min)) {
2067                         for (i = min; i <= max; i++)
2068                             if (isLOWER(i))
2069                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
2070                     } else {
2071                         for (i = min; i <= max; i++)
2072                             if (isUPPER(i))
2073                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
2074                     }
2075                 }
2076                 else
2077 #endif
2078                     for (i = min; i <= max; i++)
2079 #ifdef EBCDIC
2080                         if (has_utf8) {
2081                             const U8 ch = (U8)NATIVE_TO_UTF(i);
2082                             if (UNI_IS_INVARIANT(ch))
2083                                 *d++ = (U8)i;
2084                             else {
2085                                 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2086                                 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2087                             }
2088                         }
2089                         else
2090 #endif
2091                             *d++ = (char)i;
2092
2093 #ifdef EBCDIC
2094                 if (uvmax) {
2095                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2096                     if (uvmax > 0x101)
2097                         *d++ = (char)UTF_TO_NATIVE(0xff);
2098                     if (uvmax > 0x100)
2099                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2100                 }
2101 #endif
2102
2103                 /* mark the range as done, and continue */
2104                 dorange = FALSE;
2105                 didrange = TRUE;
2106 #ifdef EBCDIC
2107                 literal_endpoint = 0;
2108 #endif
2109                 continue;
2110             }
2111
2112             /* range begins (ignore - as first or last char) */
2113             else if (*s == '-' && s+1 < send  && s != start) {
2114                 if (didrange) {
2115                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2116                 }
2117                 if (has_utf8
2118 #ifdef EBCDIC
2119                     && !native_range
2120 #endif
2121                     ) {
2122                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
2123                     s++;
2124                     continue;
2125                 }
2126                 dorange = TRUE;
2127                 s++;
2128             }
2129             else {
2130                 didrange = FALSE;
2131 #ifdef EBCDIC
2132                 literal_endpoint = 0;
2133                 native_range = TRUE;
2134 #endif
2135             }
2136         }
2137
2138         /* if we get here, we're not doing a transliteration */
2139
2140         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2141            except for the last char, which will be done separately. */
2142         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2143             if (s[2] == '#') {
2144                 while (s+1 < send && *s != ')')
2145                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2146             }
2147             else if (s[2] == '{' /* This should match regcomp.c */
2148                     || (s[2] == '?' && s[3] == '{'))
2149             {
2150                 I32 count = 1;
2151                 char *regparse = s + (s[2] == '{' ? 3 : 4);
2152                 char c;
2153
2154                 while (count && (c = *regparse)) {
2155                     if (c == '\\' && regparse[1])
2156                         regparse++;
2157                     else if (c == '{')
2158                         count++;
2159                     else if (c == '}')
2160                         count--;
2161                     regparse++;
2162                 }
2163                 if (*regparse != ')')
2164                     regparse--;         /* Leave one char for continuation. */
2165                 while (s < regparse)
2166                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2167             }
2168         }
2169
2170         /* likewise skip #-initiated comments in //x patterns */
2171         else if (*s == '#' && PL_lex_inpat &&
2172           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2173             while (s+1 < send && *s != '\n')
2174                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2175         }
2176
2177         /* check for embedded arrays
2178            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2179            */
2180         else if (*s == '@' && s[1]) {
2181             if (isALNUM_lazy_if(s+1,UTF))
2182                 break;
2183             if (strchr(":'{$", s[1]))
2184                 break;
2185             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2186                 break; /* in regexp, neither @+ nor @- are interpolated */
2187         }
2188
2189         /* check for embedded scalars.  only stop if we're sure it's a
2190            variable.
2191         */
2192         else if (*s == '$') {
2193             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
2194                 break;
2195             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2196                 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2197                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2198                                 "Possible unintended interpolation of $\\ in regex");
2199                 }
2200                 break;          /* in regexp, $ might be tail anchor */
2201             }
2202         }
2203
2204         /* End of else if chain - OP_TRANS rejoin rest */
2205
2206         /* backslashes */
2207         if (*s == '\\' && s+1 < send) {
2208             s++;
2209
2210             /* deprecate \1 in strings and substitution replacements */
2211             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2212                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2213             {
2214                 if (ckWARN(WARN_SYNTAX))
2215                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2216                 *--s = '$';
2217                 break;
2218             }
2219
2220             /* string-change backslash escapes */
2221             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2222                 --s;
2223                 break;
2224             }
2225             /* skip any other backslash escapes in a pattern */
2226             else if (PL_lex_inpat) {
2227                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2228                 goto default_action;
2229             }
2230
2231             /* if we get here, it's either a quoted -, or a digit */
2232             switch (*s) {
2233
2234             /* quoted - in transliterations */
2235             case '-':
2236                 if (PL_lex_inwhat == OP_TRANS) {
2237                     *d++ = *s++;
2238                     continue;
2239                 }
2240                 /* FALL THROUGH */
2241             default:
2242                 {
2243                     if ((isALPHA(*s) || isDIGIT(*s)) &&
2244                         ckWARN(WARN_MISC))
2245                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2246                                     "Unrecognized escape \\%c passed through",
2247                                     *s);
2248                     /* default action is to copy the quoted character */
2249                     goto default_action;
2250                 }
2251
2252             /* eg. \132 indicates the octal constant 0x132 */
2253             case '0': case '1': case '2': case '3':
2254             case '4': case '5': case '6': case '7':
2255                 {
2256                     I32 flags = 0;
2257                     STRLEN len = 3;
2258                     uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2259                     s += len;
2260                 }
2261                 goto NUM_ESCAPE_INSERT;
2262
2263             /* eg. \x24 indicates the hex constant 0x24 */
2264             case 'x':
2265                 ++s;
2266                 if (*s == '{') {
2267                     char* const e = strchr(s, '}');
2268                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2269                       PERL_SCAN_DISALLOW_PREFIX;
2270                     STRLEN len;
2271
2272                     ++s;
2273                     if (!e) {
2274                         yyerror("Missing right brace on \\x{}");
2275                         continue;
2276                     }
2277                     len = e - s;
2278                     uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2279                     s = e + 1;
2280                 }
2281                 else {
2282                     {
2283                         STRLEN len = 2;
2284                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2285                         uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2286                         s += len;
2287                     }
2288                 }
2289
2290               NUM_ESCAPE_INSERT:
2291                 /* Insert oct, hex, or \N{U+...} escaped character.  There will
2292                  * always be enough room in sv since such escapes will be
2293                  * longer than any UTF-8 sequence they can end up as, except if
2294                  * they force us to recode the rest of the string into utf8 */
2295
2296                 /* Here uv is the ordinal of the next character being added in
2297                  * unicode (converted from native).  (It has to be done before
2298                  * here because \N is interpreted as unicode, and oct and hex
2299                  * as native.) */
2300                 if (!UNI_IS_INVARIANT(uv)) {
2301                     if (!has_utf8 && uv > 255) {
2302                         /* Might need to recode whatever we have accumulated so
2303                          * far if it contains any chars variant in utf8 or
2304                          * utf-ebcdic. */
2305
2306                         SvCUR_set(sv, d - SvPVX_const(sv));
2307                         SvPOK_on(sv);
2308                         *d = '\0';
2309                         /* See Note on sizing above.  */
2310                         sv_utf8_upgrade_flags_grow(sv,
2311                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2312                                         UNISKIP(uv) + (STRLEN)(send - s) + 1);
2313                         d = SvPVX(sv) + SvCUR(sv);
2314                         has_utf8 = TRUE;
2315                     }
2316
2317                     if (has_utf8) {
2318                         d = (char*)uvuni_to_utf8((U8*)d, uv);
2319                         if (PL_lex_inwhat == OP_TRANS &&
2320                             PL_sublex_info.sub_op) {
2321                             PL_sublex_info.sub_op->op_private |=
2322                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2323                                              : OPpTRANS_TO_UTF);
2324                         }
2325 #ifdef EBCDIC
2326                         if (uv > 255 && !dorange)
2327                             native_range = FALSE;
2328 #endif
2329                     }
2330                     else {
2331                         *d++ = (char)uv;
2332                     }
2333                 }
2334                 else {
2335                     *d++ = (char) uv;
2336                 }
2337                 continue;
2338
2339             /* \N{LATIN SMALL LETTER A} is a named character, and so is
2340              * \N{U+0041} */
2341             case 'N':
2342                 ++s;
2343                 if (*s == '{') {
2344                     char* e = strchr(s, '}');
2345                     SV *res;
2346                     STRLEN len;
2347                     const char *str;
2348
2349                     if (!e) {
2350                         yyerror("Missing right brace on \\N{}");
2351                         e = s - 1;
2352                         goto cont_scan;
2353                     }
2354                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2355                         /* \N{U+...} The ... is a unicode value even on EBCDIC
2356                          * machines */
2357                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2358                           PERL_SCAN_DISALLOW_PREFIX;
2359                         s += 3;
2360                         len = e - s;
2361                         uv = grok_hex(s, &len, &flags, NULL);
2362                         if ( e > s && len != (STRLEN)(e - s) ) {
2363                             uv = 0xFFFD;
2364                         }
2365                         s = e + 1;
2366                         goto NUM_ESCAPE_INSERT;
2367                     }
2368                     res = newSVpvn(s + 1, e - s - 1);
2369                     res = new_constant( NULL, 0, "charnames",
2370                                         res, NULL, s - 2, e - s + 3 );
2371                     if (has_utf8)
2372                         sv_utf8_upgrade(res);
2373                     str = SvPV_const(res,len);
2374 #ifdef EBCDIC_NEVER_MIND
2375                     /* charnames uses pack U and that has been
2376                      * recently changed to do the below uni->native
2377                      * mapping, so this would be redundant (and wrong,
2378                      * the code point would be doubly converted).
2379                      * But leave this in just in case the pack U change
2380                      * gets revoked, but the semantics is still
2381                      * desireable for charnames. --jhi */
2382                     {
2383                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2384
2385                          if (uv < 0x100) {
2386                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2387
2388                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2389                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2390                               str = SvPV_const(res, len);
2391                          }
2392                     }
2393 #endif
2394                     /* If destination is not in utf8 but this new character is,
2395                      * recode the dest to utf8 */
2396                     if (!has_utf8 && SvUTF8(res)) {
2397                         SvCUR_set(sv, d - SvPVX_const(sv));
2398                         SvPOK_on(sv);
2399                         *d = '\0';
2400                         /* See Note on sizing above.  */
2401                         sv_utf8_upgrade_flags_grow(sv,
2402                                             SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2403                                             len + (STRLEN)(send - s) + 1);
2404                         d = SvPVX(sv) + SvCUR(sv);
2405                         has_utf8 = TRUE;
2406                     } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2407
2408                         /* See Note on sizing above.  (NOTE: SvCUR() is not set
2409                          * correctly here). */
2410                         const STRLEN off = d - SvPVX_const(sv);
2411                         d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2412                     }
2413 #ifdef EBCDIC
2414                     if (!dorange)
2415                         native_range = FALSE; /* \N{} is guessed to be Unicode */
2416 #endif
2417                     Copy(str, d, len, char);
2418                     d += len;
2419                     SvREFCNT_dec(res);
2420                   cont_scan:
2421                     s = e + 1;
2422                 }
2423                 else
2424                     yyerror("Missing braces on \\N{}");
2425                 continue;
2426
2427             /* \c is a control character */
2428             case 'c':
2429                 s++;
2430                 if (s < send) {
2431                     U8 c = *s++;
2432 #ifdef EBCDIC
2433                     if (isLOWER(c))
2434                         c = toUPPER(c);
2435 #endif
2436                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2437                 }
2438                 else {
2439                     yyerror("Missing control char name in \\c");
2440                 }
2441                 continue;
2442
2443             /* printf-style backslashes, formfeeds, newlines, etc */
2444             case 'b':
2445                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2446                 break;
2447             case 'n':
2448                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2449                 break;
2450             case 'r':
2451                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2452                 break;
2453             case 'f':
2454                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2455                 break;
2456             case 't':
2457                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2458                 break;
2459             case 'e':
2460                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2461                 break;
2462             case 'a':
2463                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2464                 break;
2465             } /* end switch */
2466
2467             s++;
2468             continue;
2469         } /* end if (backslash) */
2470 #ifdef EBCDIC
2471         else
2472             literal_endpoint++;
2473 #endif
2474
2475     default_action:
2476         /* If we started with encoded form, or already know we want it,
2477            then encode the next character */
2478         if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2479             STRLEN len  = 1;
2480
2481
2482             /* One might think that it is wasted effort in the case of the
2483              * source being utf8 (this_utf8 == TRUE) to take the next character
2484              * in the source, convert it to an unsigned value, and then convert
2485              * it back again.  But the source has not been validated here.  The
2486              * routine that does the conversion checks for errors like
2487              * malformed utf8 */
2488
2489             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2490             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2491             if (!has_utf8) {
2492                 SvCUR_set(sv, d - SvPVX_const(sv));
2493                 SvPOK_on(sv);
2494                 *d = '\0';
2495                 /* See Note on sizing above.  */
2496                 sv_utf8_upgrade_flags_grow(sv,
2497                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2498                                         need + (STRLEN)(send - s) + 1);
2499                 d = SvPVX(sv) + SvCUR(sv);
2500                 has_utf8 = TRUE;
2501             } else if (need > len) {
2502                 /* encoded value larger than old, may need extra space (NOTE:
2503                  * SvCUR() is not set correctly here).   See Note on sizing
2504                  * above.  */
2505                 const STRLEN off = d - SvPVX_const(sv);
2506                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2507             }
2508             s += len;
2509
2510             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2511 #ifdef EBCDIC
2512             if (uv > 255 && !dorange)
2513                 native_range = FALSE;
2514 #endif
2515         }
2516         else {
2517             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2518         }
2519     } /* while loop to process each character */
2520
2521     /* terminate the string and set up the sv */
2522     *d = '\0';
2523     SvCUR_set(sv, d - SvPVX_const(sv));
2524     if (SvCUR(sv) >= SvLEN(sv))
2525         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2526
2527     SvPOK_on(sv);
2528     if (PL_encoding && !has_utf8) {
2529         sv_recode_to_utf8(sv, PL_encoding);
2530         if (SvUTF8(sv))
2531             has_utf8 = TRUE;
2532     }
2533     if (has_utf8) {
2534         SvUTF8_on(sv);
2535         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2536             PL_sublex_info.sub_op->op_private |=
2537                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2538         }
2539     }
2540
2541     /* shrink the sv if we allocated more than we used */
2542     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2543         SvPV_shrink_to_cur(sv);
2544     }
2545
2546     /* return the substring (via pl_yylval) only if we parsed anything */
2547     if (s > PL_bufptr) {
2548         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2549             const char *const key = PL_lex_inpat ? "qr" : "q";
2550             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2551             const char *type;
2552             STRLEN typelen;
2553
2554             if (PL_lex_inwhat == OP_TRANS) {
2555                 type = "tr";
2556                 typelen = 2;
2557             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2558                 type = "s";
2559                 typelen = 1;
2560             } else  {
2561                 type = "qq";
2562                 typelen = 2;
2563             }
2564
2565             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2566                                 type, typelen);
2567         }
2568         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2569     } else
2570         SvREFCNT_dec(sv);
2571     return s;
2572 }
2573
2574 /* S_intuit_more
2575  * Returns TRUE if there's more to the expression (e.g., a subscript),
2576  * FALSE otherwise.
2577  *
2578  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2579  *
2580  * ->[ and ->{ return TRUE
2581  * { and [ outside a pattern are always subscripts, so return TRUE
2582  * if we're outside a pattern and it's not { or [, then return FALSE
2583  * if we're in a pattern and the first char is a {
2584  *   {4,5} (any digits around the comma) returns FALSE
2585  * if we're in a pattern and the first char is a [
2586  *   [] returns FALSE
2587  *   [SOMETHING] has a funky algorithm to decide whether it's a
2588  *      character class or not.  It has to deal with things like
2589  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2590  * anything else returns TRUE
2591  */
2592
2593 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2594
2595 STATIC int
2596 S_intuit_more(pTHX_ register char *s)
2597 {
2598     dVAR;
2599
2600     PERL_ARGS_ASSERT_INTUIT_MORE;
2601
2602     if (PL_lex_brackets)
2603         return TRUE;
2604     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2605         return TRUE;
2606     if (*s != '{' && *s != '[')
2607         return FALSE;
2608     if (!PL_lex_inpat)
2609         return TRUE;
2610
2611     /* In a pattern, so maybe we have {n,m}. */
2612     if (*s == '{') {
2613         s++;
2614         if (!isDIGIT(*s))
2615             return TRUE;
2616         while (isDIGIT(*s))
2617             s++;
2618         if (*s == ',')
2619             s++;
2620         while (isDIGIT(*s))
2621             s++;
2622         if (*s == '}')
2623             return FALSE;
2624         return TRUE;
2625
2626     }
2627
2628     /* On the other hand, maybe we have a character class */
2629
2630     s++;
2631     if (*s == ']' || *s == '^')
2632         return FALSE;
2633     else {
2634         /* this is terrifying, and it works */
2635         int weight = 2;         /* let's weigh the evidence */
2636         char seen[256];
2637         unsigned char un_char = 255, last_un_char;
2638         const char * const send = strchr(s,']');
2639         char tmpbuf[sizeof PL_tokenbuf * 4];
2640
2641         if (!send)              /* has to be an expression */
2642             return TRUE;
2643
2644         Zero(seen,256,char);
2645         if (*s == '$')
2646             weight -= 3;
2647         else if (isDIGIT(*s)) {
2648             if (s[1] != ']') {
2649                 if (isDIGIT(s[1]) && s[2] == ']')
2650                     weight -= 10;
2651             }
2652             else
2653                 weight -= 100;
2654         }
2655         for (; s < send; s++) {
2656             last_un_char = un_char;
2657             un_char = (unsigned char)*s;
2658             switch (*s) {
2659             case '@':
2660             case '&':
2661             case '$':
2662                 weight -= seen[un_char] * 10;
2663                 if (isALNUM_lazy_if(s+1,UTF)) {
2664                     int len;
2665                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2666                     len = (int)strlen(tmpbuf);
2667                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2668                         weight -= 100;
2669                     else
2670                         weight -= 10;
2671                 }
2672                 else if (*s == '$' && s[1] &&
2673                   strchr("[#!%*<>()-=",s[1])) {
2674                     if (/*{*/ strchr("])} =",s[2]))
2675                         weight -= 10;
2676                     else
2677                         weight -= 1;
2678                 }
2679                 break;
2680             case '\\':
2681                 un_char = 254;
2682                 if (s[1]) {
2683                     if (strchr("wds]",s[1]))
2684                         weight += 100;
2685                     else if (seen[(U8)'\''] || seen[(U8)'"'])
2686                         weight += 1;
2687                     else if (strchr("rnftbxcav",s[1]))
2688                         weight += 40;
2689                     else if (isDIGIT(s[1])) {
2690                         weight += 40;
2691                         while (s[1] && isDIGIT(s[1]))
2692                             s++;
2693                     }
2694                 }
2695                 else
2696                     weight += 100;
2697                 break;
2698             case '-':
2699                 if (s[1] == '\\')
2700                     weight += 50;
2701                 if (strchr("aA01! ",last_un_char))
2702                     weight += 30;
2703                 if (strchr("zZ79~",s[1]))
2704                     weight += 30;
2705                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2706                     weight -= 5;        /* cope with negative subscript */
2707                 break;
2708             default:
2709                 if (!isALNUM(last_un_char)
2710                     && !(last_un_char == '$' || last_un_char == '@'
2711                          || last_un_char == '&')
2712                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2713                     char *d = tmpbuf;
2714                     while (isALPHA(*s))
2715                         *d++ = *s++;
2716                     *d = '\0';
2717                     if (keyword(tmpbuf, d - tmpbuf, 0))
2718                         weight -= 150;
2719                 }
2720                 if (un_char == last_un_char + 1)
2721                     weight += 5;
2722                 weight -= seen[un_char];
2723                 break;
2724             }
2725             seen[un_char]++;
2726         }
2727         if (weight >= 0)        /* probably a character class */
2728             return FALSE;
2729     }
2730
2731     return TRUE;
2732 }
2733
2734 /*
2735  * S_intuit_method
2736  *
2737  * Does all the checking to disambiguate
2738  *   foo bar
2739  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2740  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2741  *
2742  * First argument is the stuff after the first token, e.g. "bar".
2743  *
2744  * Not a method if bar is a filehandle.
2745  * Not a method if foo is a subroutine prototyped to take a filehandle.
2746  * Not a method if it's really "Foo $bar"
2747  * Method if it's "foo $bar"
2748  * Not a method if it's really "print foo $bar"
2749  * Method if it's really "foo package::" (interpreted as package->foo)
2750  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2751  * Not a method if bar is a filehandle or package, but is quoted with
2752  *   =>
2753  */
2754
2755 STATIC int
2756 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2757 {
2758     dVAR;
2759     char *s = start + (*start == '$');
2760     char tmpbuf[sizeof PL_tokenbuf];
2761     STRLEN len;
2762     GV* indirgv;
2763 #ifdef PERL_MAD
2764     int soff;
2765 #endif
2766
2767     PERL_ARGS_ASSERT_INTUIT_METHOD;
2768
2769     if (gv) {
2770         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2771             return 0;
2772         if (cv) {
2773             if (SvPOK(cv)) {
2774                 const char *proto = SvPVX_const(cv);
2775                 if (proto) {
2776                     if (*proto == ';')
2777                         proto++;
2778                     if (*proto == '*')
2779                         return 0;
2780                 }
2781             }
2782         } else
2783             gv = NULL;
2784     }
2785     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2786     /* start is the beginning of the possible filehandle/object,
2787      * and s is the end of it
2788      * tmpbuf is a copy of it
2789      */
2790
2791     if (*start == '$') {
2792         if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2793                 isUPPER(*PL_tokenbuf))
2794             return 0;
2795 #ifdef PERL_MAD
2796         len = start - SvPVX(PL_linestr);
2797 #endif
2798         s = PEEKSPACE(s);
2799 #ifdef PERL_MAD
2800         start = SvPVX(PL_linestr) + len;
2801 #endif
2802         PL_bufptr = start;
2803         PL_expect = XREF;
2804         return *s == '(' ? FUNCMETH : METHOD;
2805     }
2806     if (!keyword(tmpbuf, len, 0)) {
2807         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2808             len -= 2;
2809             tmpbuf[len] = '\0';
2810 #ifdef PERL_MAD
2811             soff = s - SvPVX(PL_linestr);
2812 #endif
2813             goto bare_package;
2814         }
2815         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2816         if (indirgv && GvCVu(indirgv))
2817             return 0;
2818         /* filehandle or package name makes it a method */
2819         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2820 #ifdef PERL_MAD
2821             soff = s - SvPVX(PL_linestr);
2822 #endif
2823             s = PEEKSPACE(s);
2824             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2825                 return 0;       /* no assumptions -- "=>" quotes bearword */
2826       bare_package:
2827             start_force(PL_curforce);
2828             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2829                                                    newSVpvn(tmpbuf,len));
2830             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2831             if (PL_madskills)
2832                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2833             PL_expect = XTERM;
2834             force_next(WORD);
2835             PL_bufptr = s;
2836 #ifdef PERL_MAD
2837             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2838 #endif
2839             return *s == '(' ? FUNCMETH : METHOD;
2840         }
2841     }
2842     return 0;
2843 }
2844
2845 /* Encoded script support. filter_add() effectively inserts a
2846  * 'pre-processing' function into the current source input stream.
2847  * Note that the filter function only applies to the current source file
2848  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2849  *
2850  * The datasv parameter (which may be NULL) can be used to pass
2851  * private data to this instance of the filter. The filter function
2852  * can recover the SV using the FILTER_DATA macro and use it to
2853  * store private buffers and state information.
2854  *
2855  * The supplied datasv parameter is upgraded to a PVIO type
2856  * and the IoDIRP/IoANY field is used to store the function pointer,
2857  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2858  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2859  * private use must be set using malloc'd pointers.
2860  */
2861
2862 SV *
2863 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2864 {
2865     dVAR;
2866     if (!funcp)
2867         return NULL;
2868
2869     if (!PL_parser)
2870         return NULL;
2871
2872     if (!PL_rsfp_filters)
2873         PL_rsfp_filters = newAV();
2874     if (!datasv)
2875         datasv = newSV(0);
2876     SvUPGRADE(datasv, SVt_PVIO);
2877     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2878     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2879     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2880                           FPTR2DPTR(void *, IoANY(datasv)),
2881                           SvPV_nolen(datasv)));
2882     av_unshift(PL_rsfp_filters, 1);
2883     av_store(PL_rsfp_filters, 0, datasv) ;
2884     return(datasv);
2885 }
2886
2887
2888 /* Delete most recently added instance of this filter function. */
2889 void
2890 Perl_filter_del(pTHX_ filter_t funcp)
2891 {
2892     dVAR;
2893     SV *datasv;
2894
2895     PERL_ARGS_ASSERT_FILTER_DEL;
2896
2897 #ifdef DEBUGGING
2898     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2899                           FPTR2DPTR(void*, funcp)));
2900 #endif
2901     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2902         return;
2903     /* if filter is on top of stack (usual case) just pop it off */
2904     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2905     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2906         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2907         IoANY(datasv) = (void *)NULL;
2908         sv_free(av_pop(PL_rsfp_filters));
2909
2910         return;
2911     }
2912     /* we need to search for the correct entry and clear it     */
2913     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2914 }
2915
2916
2917 /* Invoke the idxth filter function for the current rsfp.        */
2918 /* maxlen 0 = read one text line */
2919 I32
2920 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2921 {
2922     dVAR;
2923     filter_t funcp;
2924     SV *datasv = NULL;
2925     /* This API is bad. It should have been using unsigned int for maxlen.
2926        Not sure if we want to change the API, but if not we should sanity
2927        check the value here.  */
2928     const unsigned int correct_length
2929         = maxlen < 0 ?
2930 #ifdef PERL_MICRO
2931         0x7FFFFFFF
2932 #else
2933         INT_MAX
2934 #endif
2935         : maxlen;
2936
2937     PERL_ARGS_ASSERT_FILTER_READ;
2938
2939     if (!PL_parser || !PL_rsfp_filters)
2940         return -1;
2941     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2942         /* Provide a default input filter to make life easy.    */
2943         /* Note that we append to the line. This is handy.      */
2944         DEBUG_P(PerlIO_printf(Perl_debug_log,
2945                               "filter_read %d: from rsfp\n", idx));
2946         if (correct_length) {
2947             /* Want a block */
2948             int len ;
2949             const int old_len = SvCUR(buf_sv);
2950
2951             /* ensure buf_sv is large enough */
2952             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2953             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2954                                    correct_length)) <= 0) {
2955                 if (PerlIO_error(PL_rsfp))
2956                     return -1;          /* error */
2957                 else
2958                     return 0 ;          /* end of file */
2959             }
2960             SvCUR_set(buf_sv, old_len + len) ;
2961         } else {
2962             /* Want a line */
2963             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2964                 if (PerlIO_error(PL_rsfp))
2965                     return -1;          /* error */
2966                 else
2967                     return 0 ;          /* end of file */
2968             }
2969         }
2970         return SvCUR(buf_sv);
2971     }
2972     /* Skip this filter slot if filter has been deleted */
2973     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2974         DEBUG_P(PerlIO_printf(Perl_debug_log,
2975                               "filter_read %d: skipped (filter deleted)\n",
2976                               idx));
2977         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2978     }
2979     /* Get function pointer hidden within datasv        */
2980     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2981     DEBUG_P(PerlIO_printf(Perl_debug_log,
2982                           "filter_read %d: via function %p (%s)\n",
2983                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
2984     /* Call function. The function is expected to       */
2985     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2986     /* Return: <0:error, =0:eof, >0:not eof             */
2987     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2988 }
2989
2990 STATIC char *
2991 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2992 {
2993     dVAR;
2994
2995     PERL_ARGS_ASSERT_FILTER_GETS;
2996
2997 #ifdef PERL_CR_FILTER
2998     if (!PL_rsfp_filters) {
2999         filter_add(S_cr_textfilter,NULL);
3000     }
3001 #endif
3002     if (PL_rsfp_filters) {
3003         if (!append)
3004             SvCUR_set(sv, 0);   /* start with empty line        */
3005         if (FILTER_READ(0, sv, 0) > 0)
3006             return ( SvPVX(sv) ) ;
3007         else
3008             return NULL ;
3009     }
3010     else
3011         return (sv_gets(sv, fp, append));
3012 }
3013
3014 STATIC HV *
3015 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3016 {
3017     dVAR;
3018     GV *gv;
3019
3020     PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3021
3022     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3023         return PL_curstash;
3024
3025     if (len > 2 &&
3026         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3027         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3028     {
3029         return GvHV(gv);                        /* Foo:: */
3030     }
3031
3032     /* use constant CLASS => 'MyClass' */
3033     gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3034     if (gv && GvCV(gv)) {
3035         SV * const sv = cv_const_sv(GvCV(gv));
3036         if (sv)
3037             pkgname = SvPV_const(sv, len);
3038     }
3039
3040     return gv_stashpvn(pkgname, len, 0);
3041 }
3042
3043 /*
3044  * S_readpipe_override
3045  * Check whether readpipe() is overriden, and generates the appropriate
3046  * optree, provided sublex_start() is called afterwards.
3047  */
3048 STATIC void
3049 S_readpipe_override(pTHX)
3050 {
3051     GV **gvp;
3052     GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3053     pl_yylval.ival = OP_BACKTICK;
3054     if ((gv_readpipe
3055                 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3056             ||
3057             ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3058              && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3059              && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3060     {
3061         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3062             append_elem(OP_LIST,
3063                 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3064                 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3065     }
3066 }
3067
3068 #ifdef PERL_MAD
3069  /*
3070  * Perl_madlex
3071  * The intent of this yylex wrapper is to minimize the changes to the
3072  * tokener when we aren't interested in collecting madprops.  It remains
3073  * to be seen how successful this strategy will be...
3074  */
3075
3076 int
3077 Perl_madlex(pTHX)
3078 {
3079     int optype;
3080     char *s = PL_bufptr;
3081
3082     /* make sure PL_thiswhite is initialized */
3083     PL_thiswhite = 0;
3084     PL_thismad = 0;
3085
3086     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3087     if (PL_pending_ident)
3088         return S_pending_ident(aTHX);
3089
3090     /* previous token ate up our whitespace? */
3091     if (!PL_lasttoke && PL_nextwhite) {
3092         PL_thiswhite = PL_nextwhite;
3093         PL_nextwhite = 0;
3094     }
3095
3096     /* isolate the token, and figure out where it is without whitespace */
3097     PL_realtokenstart = -1;
3098     PL_thistoken = 0;
3099     optype = yylex();
3100     s = PL_bufptr;
3101     assert(PL_curforce < 0);
3102
3103     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
3104         if (!PL_thistoken) {
3105             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3106                 PL_thistoken = newSVpvs("");
3107             else {
3108                 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3109                 PL_thistoken = newSVpvn(tstart, s - tstart);
3110             }
3111         }
3112         if (PL_thismad) /* install head */
3113             CURMAD('X', PL_thistoken);
3114     }
3115
3116     /* last whitespace of a sublex? */
3117     if (optype == ')' && PL_endwhite) {
3118         CURMAD('X', PL_endwhite);
3119     }
3120
3121     if (!PL_thismad) {
3122
3123         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
3124         if (!PL_thiswhite && !PL_endwhite && !optype) {
3125             sv_free(PL_thistoken);
3126             PL_thistoken = 0;
3127             return 0;
3128         }
3129
3130         /* put off final whitespace till peg */
3131         if (optype == ';' && !PL_rsfp) {
3132             PL_nextwhite = PL_thiswhite;
3133             PL_thiswhite = 0;
3134         }
3135         else if (PL_thisopen) {
3136             CURMAD('q', PL_thisopen);
3137             if (PL_thistoken)
3138                 sv_free(PL_thistoken);
3139             PL_thistoken = 0;
3140         }
3141         else {
3142             /* Store actual token text as madprop X */
3143             CURMAD('X', PL_thistoken);
3144         }
3145
3146         if (PL_thiswhite) {
3147             /* add preceding whitespace as madprop _ */
3148             CURMAD('_', PL_thiswhite);
3149         }
3150
3151         if (PL_thisstuff) {
3152             /* add quoted material as madprop = */
3153             CURMAD('=', PL_thisstuff);
3154         }
3155
3156         if (PL_thisclose) {
3157             /* add terminating quote as madprop Q */
3158             CURMAD('Q', PL_thisclose);
3159         }
3160     }
3161
3162     /* special processing based on optype */
3163
3164     switch (optype) {
3165
3166     /* opval doesn't need a TOKEN since it can already store mp */
3167     case WORD:
3168     case METHOD:
3169     case FUNCMETH:
3170     case THING:
3171     case PMFUNC:
3172     case PRIVATEREF:
3173     case FUNC0SUB:
3174     case UNIOPSUB:
3175     case LSTOPSUB:
3176         if (pl_yylval.opval)
3177             append_madprops(PL_thismad, pl_yylval.opval, 0);
3178         PL_thismad = 0;
3179         return optype;
3180
3181     /* fake EOF */
3182     case 0:
3183         optype = PEG;
3184         if (PL_endwhite) {
3185             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3186             PL_endwhite = 0;
3187         }
3188         break;
3189
3190     case ']':
3191     case '}':
3192         if (PL_faketokens)
3193             break;
3194         /* remember any fake bracket that lexer is about to discard */
3195         if (PL_lex_brackets == 1 &&
3196             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3197         {
3198             s = PL_bufptr;
3199             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3200                 s++;
3201             if (*s == '}') {
3202                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3203                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3204                 PL_thiswhite = 0;
3205                 PL_bufptr = s - 1;
3206                 break;  /* don't bother looking for trailing comment */
3207             }
3208             else
3209                 s = PL_bufptr;
3210         }
3211         if (optype == ']')
3212             break;
3213         /* FALLTHROUGH */
3214
3215     /* attach a trailing comment to its statement instead of next token */
3216     case ';':
3217         if (PL_faketokens)
3218             break;
3219         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3220             s = PL_bufptr;
3221             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3222                 s++;
3223             if (*s == '\n' || *s == '#') {
3224                 while (s < PL_bufend && *s != '\n')
3225                     s++;
3226                 if (s < PL_bufend)
3227                     s++;
3228                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3229                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3230                 PL_thiswhite = 0;
3231                 PL_bufptr = s;
3232             }
3233         }
3234         break;
3235
3236     /* pval */
3237     case LABEL:
3238         break;
3239
3240     /* ival */
3241     default:
3242         break;
3243
3244     }
3245
3246     /* Create new token struct.  Note: opvals return early above. */
3247     pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3248     PL_thismad = 0;
3249     return optype;
3250 }
3251 #endif
3252
3253 STATIC char *
3254 S_tokenize_use(pTHX_ int is_use, char *s) {
3255     dVAR;
3256
3257     PERL_ARGS_ASSERT_TOKENIZE_USE;
3258
3259     if (PL_expect != XSTATE)
3260         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3261                     is_use ? "use" : "no"));
3262     s = SKIPSPACE1(s);
3263     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3264         s = force_version(s, TRUE);
3265         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3266             start_force(PL_curforce);
3267             NEXTVAL_NEXTTOKE.opval = NULL;
3268             force_next(WORD);
3269         }
3270         else if (*s == 'v') {
3271             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3272             s = force_version(s, FALSE);
3273         }
3274     }
3275     else {
3276         s = force_word(s,WORD,FALSE,TRUE,FALSE);
3277         s = force_version(s, FALSE);
3278     }
3279     pl_yylval.ival = is_use;
3280     return s;
3281 }
3282 #ifdef DEBUGGING
3283     static const char* const exp_name[] =
3284         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3285           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3286         };
3287 #endif
3288
3289 /*
3290   yylex
3291
3292   Works out what to call the token just pulled out of the input
3293   stream.  The yacc parser takes care of taking the ops we return and
3294   stitching them into a tree.
3295
3296   Returns:
3297     PRIVATEREF
3298
3299   Structure:
3300       if read an identifier
3301           if we're in a my declaration
3302               croak if they tried to say my($foo::bar)
3303               build the ops for a my() declaration
3304           if it's an access to a my() variable
3305               are we in a sort block?
3306                   croak if my($a); $a <=> $b
3307               build ops for access to a my() variable
3308           if in a dq string, and they've said @foo and we can't find @foo
3309               croak
3310           build ops for a bareword
3311       if we already built the token before, use it.
3312 */
3313
3314
3315 #ifdef __SC__
3316 #pragma segment Perl_yylex
3317 #endif
3318 int
3319 Perl_yylex(pTHX)
3320 {
3321     dVAR;
3322     register char *s = PL_bufptr;
3323     register char *d;
3324     STRLEN len;
3325     bool bof = FALSE;
3326
3327     /* orig_keyword, gvp, and gv are initialized here because
3328      * jump to the label just_a_word_zero can bypass their
3329      * initialization later. */
3330     I32 orig_keyword = 0;
3331     GV *gv = NULL;
3332     GV **gvp = NULL;
3333
3334     DEBUG_T( {
3335         SV* tmp = newSVpvs("");
3336         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3337             (IV)CopLINE(PL_curcop),
3338             lex_state_names[PL_lex_state],
3339             exp_name[PL_expect],
3340             pv_display(tmp, s, strlen(s), 0, 60));
3341         SvREFCNT_dec(tmp);
3342     } );
3343     /* check if there's an identifier for us to look at */
3344     if (PL_pending_ident)
3345         return REPORT(S_pending_ident(aTHX));
3346
3347     /* no identifier pending identification */
3348
3349     switch (PL_lex_state) {
3350 #ifdef COMMENTARY
3351     case LEX_NORMAL:            /* Some compilers will produce faster */
3352     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3353         break;
3354 #endif
3355
3356     /* when we've already built the next token, just pull it out of the queue */
3357     case LEX_KNOWNEXT:
3358 #ifdef PERL_MAD
3359         PL_lasttoke--;
3360         pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3361         if (PL_madskills) {
3362             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3363             PL_nexttoke[PL_lasttoke].next_mad = 0;
3364             if (PL_thismad && PL_thismad->mad_key == '_') {
3365                 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3366                 PL_thismad->mad_val = 0;
3367                 mad_free(PL_thismad);
3368                 PL_thismad = 0;
3369             }
3370         }
3371         if (!PL_lasttoke) {
3372             PL_lex_state = PL_lex_defer;
3373             PL_expect = PL_lex_expect;
3374             PL_lex_defer = LEX_NORMAL;
3375             if (!PL_nexttoke[PL_lasttoke].next_type)
3376                 return yylex();
3377         }
3378 #else
3379         PL_nexttoke--;
3380         pl_yylval = PL_nextval[PL_nexttoke];
3381         if (!PL_nexttoke) {
3382             PL_lex_state = PL_lex_defer;
3383             PL_expect = PL_lex_expect;
3384             PL_lex_defer = LEX_NORMAL;
3385         }
3386 #endif
3387 #ifdef PERL_MAD
3388         /* FIXME - can these be merged?  */
3389         return(PL_nexttoke[PL_lasttoke].next_type);
3390 #else
3391         return REPORT(PL_nexttype[PL_nexttoke]);
3392 #endif
3393
3394     /* interpolated case modifiers like \L \U, including \Q and \E.
3395        when we get here, PL_bufptr is at the \
3396     */
3397     case LEX_INTERPCASEMOD:
3398 #ifdef DEBUGGING
3399         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3400             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3401 #endif
3402         /* handle \E or end of string */
3403         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3404             /* if at a \E */
3405             if (PL_lex_casemods) {
3406                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3407                 PL_lex_casestack[PL_lex_casemods] = '\0';
3408
3409                 if (PL_bufptr != PL_bufend
3410                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3411                     PL_bufptr += 2;
3412                     PL_lex_state = LEX_INTERPCONCAT;
3413 #ifdef PERL_MAD
3414                     if (PL_madskills)
3415                         PL_thistoken = newSVpvs("\\E");
3416 #endif
3417                 }
3418                 return REPORT(')');
3419             }
3420 #ifdef PERL_MAD
3421             while (PL_bufptr != PL_bufend &&
3422               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3423                 if (!PL_thiswhite)
3424                     PL_thiswhite = newSVpvs("");
3425                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3426                 PL_bufptr += 2;
3427             }
3428 #else
3429             if (PL_bufptr != PL_bufend)
3430                 PL_bufptr += 2;
3431 #endif
3432             PL_lex_state = LEX_INTERPCONCAT;
3433             return yylex();
3434         }
3435         else {
3436             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3437               "### Saw case modifier\n"); });
3438             s = PL_bufptr + 1;
3439             if (s[1] == '\\' && s[2] == 'E') {
3440 #ifdef PERL_MAD
3441                 if (!PL_thiswhite)
3442                     PL_thiswhite = newSVpvs("");
3443                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3444 #endif
3445                 PL_bufptr = s + 3;
3446                 PL_lex_state = LEX_INTERPCONCAT;
3447                 return yylex();
3448             }
3449             else {
3450                 I32 tmp;
3451                 if (!PL_madskills) /* when just compiling don't need correct */
3452                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3453                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3454                 if ((*s == 'L' || *s == 'U') &&
3455                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3456                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3457                     return REPORT(')');
3458                 }
3459                 if (PL_lex_casemods > 10)
3460                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3461                 PL_lex_casestack[PL_lex_casemods++] = *s;
3462                 PL_lex_casestack[PL_lex_casemods] = '\0';
3463                 PL_lex_state = LEX_INTERPCONCAT;
3464                 start_force(PL_curforce);
3465                 NEXTVAL_NEXTTOKE.ival = 0;
3466                 force_next('(');
3467                 start_force(PL_curforce);
3468                 if (*s == 'l')
3469                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3470                 else if (*s == 'u')
3471                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3472                 else if (*s == 'L')
3473                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3474                 else if (*s == 'U')
3475                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3476                 else if (*s == 'Q')
3477                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3478                 else
3479                     Perl_croak(aTHX_ "panic: yylex");
3480                 if (PL_madskills) {
3481                     SV* const tmpsv = newSVpvs("\\ ");
3482                     /* replace the space with the character we want to escape
3483                      */
3484                     SvPVX(tmpsv)[1] = *s;
3485                     curmad('_', tmpsv);
3486                 }
3487                 PL_bufptr = s + 1;
3488             }
3489             force_next(FUNC);
3490             if (PL_lex_starts) {
3491                 s = PL_bufptr;
3492                 PL_lex_starts = 0;
3493 #ifdef PERL_MAD
3494                 if (PL_madskills) {
3495                     if (PL_thistoken)
3496                         sv_free(PL_thistoken);
3497                     PL_thistoken = newSVpvs("");
3498                 }
3499 #endif
3500                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3501                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3502                     OPERATOR(',');
3503                 else
3504                     Aop(OP_CONCAT);
3505             }
3506             else
3507                 return yylex();
3508         }
3509
3510     case LEX_INTERPPUSH:
3511         return REPORT(sublex_push());
3512
3513     case LEX_INTERPSTART:
3514         if (PL_bufptr == PL_bufend)
3515             return REPORT(sublex_done());
3516         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3517               "### Interpolated variable\n"); });
3518         PL_expect = XTERM;
3519         PL_lex_dojoin = (*PL_bufptr == '@');
3520         PL_lex_state = LEX_INTERPNORMAL;
3521         if (PL_lex_dojoin) {
3522             start_force(PL_curforce);
3523             NEXTVAL_NEXTTOKE.ival = 0;
3524             force_next(',');
3525             start_force(PL_curforce);
3526             force_ident("\"", '$');
3527             start_force(PL_curforce);
3528             NEXTVAL_NEXTTOKE.ival = 0;
3529             force_next('$');
3530             start_force(PL_curforce);
3531             NEXTVAL_NEXTTOKE.ival = 0;
3532             force_next('(');
3533             start_force(PL_curforce);
3534             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3535             force_next(FUNC);
3536         }
3537         if (PL_lex_starts++) {
3538             s = PL_bufptr;
3539 #ifdef PERL_MAD
3540             if (PL_madskills) {
3541                 if (PL_thistoken)
3542                     sv_free(PL_thistoken);
3543                 PL_thistoken = newSVpvs("");
3544             }
3545 #endif
3546             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3547             if (!PL_lex_casemods && PL_lex_inpat)
3548                 OPERATOR(',');
3549             else
3550                 Aop(OP_CONCAT);
3551         }
3552         return yylex();
3553
3554     case LEX_INTERPENDMAYBE:
3555         if (intuit_more(PL_bufptr)) {
3556             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3557             break;
3558         }
3559         /* FALL THROUGH */
3560
3561     case LEX_INTERPEND:
3562         if (PL_lex_dojoin) {
3563             PL_lex_dojoin = FALSE;
3564             PL_lex_state = LEX_INTERPCONCAT;
3565 #ifdef PERL_MAD
3566             if (PL_madskills) {
3567                 if (PL_thistoken)
3568                     sv_free(PL_thistoken);
3569                 PL_thistoken = newSVpvs("");
3570             }
3571 #endif
3572             return REPORT(')');
3573         }
3574         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3575             && SvEVALED(PL_lex_repl))
3576         {
3577             if (PL_bufptr != PL_bufend)
3578                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3579             PL_lex_repl = NULL;
3580         }
3581         /* FALLTHROUGH */
3582     case LEX_INTERPCONCAT:
3583 #ifdef DEBUGGING
3584         if (PL_lex_brackets)
3585             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3586 #endif
3587         if (PL_bufptr == PL_bufend)
3588             return REPORT(sublex_done());
3589
3590         if (SvIVX(PL_linestr) == '\'') {
3591             SV *sv = newSVsv(PL_linestr);
3592             if (!PL_lex_inpat)
3593                 sv = tokeq(sv);
3594             else if ( PL_hints & HINT_NEW_RE )
3595                 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3596             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3597             s = PL_bufend;
3598         }
3599         else {
3600             s = scan_const(PL_bufptr);
3601             if (*s == '\\')
3602                 PL_lex_state = LEX_INTERPCASEMOD;
3603             else
3604                 PL_lex_state = LEX_INTERPSTART;
3605         }
3606
3607         if (s != PL_bufptr) {
3608             start_force(PL_curforce);
3609             if (PL_madskills) {
3610                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3611             }
3612             NEXTVAL_NEXTTOKE = pl_yylval;
3613             PL_expect = XTERM;
3614             force_next(THING);
3615             if (PL_lex_starts++) {
3616 #ifdef PERL_MAD
3617                 if (PL_madskills) {
3618                     if (PL_thistoken)
3619                         sv_free(PL_thistoken);
3620                     PL_thistoken = newSVpvs("");
3621                 }
3622 #endif
3623                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3624                 if (!PL_lex_casemods && PL_lex_inpat)
3625                     OPERATOR(',');
3626                 else
3627                     Aop(OP_CONCAT);
3628             }
3629             else {
3630                 PL_bufptr = s;
3631                 return yylex();
3632             }
3633         }
3634
3635         return yylex();
3636     case LEX_FORMLINE:
3637         PL_lex_state = LEX_NORMAL;
3638         s = scan_formline(PL_bufptr);
3639         if (!PL_lex_formbrack)
3640             goto rightbracket;
3641         OPERATOR(';');
3642     }
3643
3644     s = PL_bufptr;
3645     PL_oldoldbufptr = PL_oldbufptr;
3646     PL_oldbufptr = s;
3647
3648   retry:
3649 #ifdef PERL_MAD
3650     if (PL_thistoken) {
3651         sv_free(PL_thistoken);
3652         PL_thistoken = 0;
3653     }
3654     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3655 #endif
3656     switch (*s) {
3657     default:
3658         if (isIDFIRST_lazy_if(s,UTF))
3659             goto keylookup;
3660         len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3661         Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
3662     case 4:
3663     case 26:
3664         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3665     case 0:
3666 #ifdef PERL_MAD
3667         if (PL_madskills)
3668             PL_faketokens = 0;
3669 #endif
3670         if (!PL_rsfp) {
3671             PL_last_uni = 0;
3672             PL_last_lop = 0;
3673             if (PL_lex_brackets) {
3674                 yyerror((const char *)
3675                         (PL_lex_formbrack
3676                          ? "Format not terminated"
3677                          : "Missing right curly or square bracket"));
3678             }
3679             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3680                         "### Tokener got EOF\n");
3681             } );
3682             TOKEN(0);
3683         }
3684         if (s++ < PL_bufend)
3685             goto retry;                 /* ignore stray nulls */
3686         PL_last_uni = 0;
3687         PL_last_lop = 0;
3688         if (!PL_in_eval && !PL_preambled) {
3689             PL_preambled = TRUE;
3690 #ifdef PERL_MAD
3691             if (PL_madskills)
3692                 PL_faketokens = 1;
3693 #endif
3694             if (PL_perldb) {
3695                 /* Generate a string of Perl code to load the debugger.
3696                  * If PERL5DB is set, it will return the contents of that,
3697                  * otherwise a compile-time require of perl5db.pl.  */
3698
3699                 const char * const pdb = PerlEnv_getenv("PERL5DB");
3700
3701                 if (pdb) {
3702                     sv_setpv(PL_linestr, pdb);
3703                     sv_catpvs(PL_linestr,";");
3704                 } else {
3705                     SETERRNO(0,SS_NORMAL);
3706                     sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3707                 }
3708             } else
3709                 sv_setpvs(PL_linestr,"");
3710             if (PL_preambleav) {
3711                 SV **svp = AvARRAY(PL_preambleav);
3712                 SV **const end = svp + AvFILLp(PL_preambleav);
3713                 while(svp <= end) {
3714                     sv_catsv(PL_linestr, *svp);
3715                     ++svp;
3716                     sv_catpvs(PL_linestr, ";");
3717                 }
3718                 sv_free(MUTABLE_SV(PL_preambleav));
3719                 PL_preambleav = NULL;
3720             }
3721             if (PL_minus_E)
3722                 sv_catpvs(PL_linestr,
3723                           "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3724             if (PL_minus_n || PL_minus_p) {
3725                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3726                 if (PL_minus_l)
3727                     sv_catpvs(PL_linestr,"chomp;");
3728                 if (PL_minus_a) {
3729                     if (PL_minus_F) {
3730                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3731                              || *PL_splitstr == '"')
3732                               && strchr(PL_splitstr + 1, *PL_splitstr))
3733                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3734                         else {
3735                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3736                                bytes can be used as quoting characters.  :-) */
3737                             const char *splits = PL_splitstr;
3738                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3739                             do {
3740                                 /* Need to \ \s  */
3741                                 if (*splits == '\\')
3742                                     sv_catpvn(PL_linestr, splits, 1);
3743                                 sv_catpvn(PL_linestr, splits, 1);
3744                             } while (*splits++);
3745                             /* This loop will embed the trailing NUL of
3746                                PL_linestr as the last thing it does before
3747                                terminating.  */
3748                             sv_catpvs(PL_linestr, ");");
3749                         }
3750                     }
3751                     else
3752                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3753                 }
3754             }
3755             sv_catpvs(PL_linestr, "\n");
3756             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3757             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3758             PL_last_lop = PL_last_uni = NULL;
3759             if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3760                 update_debugger_info(PL_linestr, NULL, 0);
3761             goto retry;
3762         }
3763         do {
3764             bof = PL_rsfp ? TRUE : FALSE;
3765             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3766               fake_eof:
3767 #ifdef PERL_MAD
3768                 PL_realtokenstart = -1;
3769 #endif
3770                 if (PL_rsfp) {
3771                     if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3772                         PerlIO_clearerr(PL_rsfp);
3773                     else
3774                         (void)PerlIO_close(PL_rsfp);
3775                     PL_rsfp = NULL;
3776                     PL_doextract = FALSE;
3777                 }
3778                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3779 #ifdef PERL_MAD
3780                     if (PL_madskills)
3781                         PL_faketokens = 1;
3782 #endif
3783                     if (PL_minus_p)
3784                         sv_setpvs(PL_linestr, ";}continue{print;}");
3785                     else
3786                         sv_setpvs(PL_linestr, ";}");
3787                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3788                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3789                     PL_last_lop = PL_last_uni = NULL;
3790                     PL_minus_n = PL_minus_p = 0;
3791                     goto retry;
3792                 }
3793                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3794                 PL_last_lop = PL_last_uni = NULL;
3795                 sv_setpvs(PL_linestr,"");
3796                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3797             }
3798             /* If it looks like the start of a BOM or raw UTF-16,
3799              * check if it in fact is. */
3800             else if (bof &&
3801                      (*s == 0 ||
3802                       *(U8*)s == 0xEF ||
3803                       *(U8*)s >= 0xFE ||
3804                       s[1] == 0)) {
3805 #ifdef PERLIO_IS_STDIO
3806 #  ifdef __GNU_LIBRARY__
3807 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3808 #      define FTELL_FOR_PIPE_IS_BROKEN
3809 #    endif
3810 #  else
3811 #    ifdef __GLIBC__
3812 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3813 #        define FTELL_FOR_PIPE_IS_BROKEN
3814 #      endif
3815 #    endif
3816 #  endif
3817 #endif
3818                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3819                 if (bof) {
3820                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3821                     s = swallow_bom((U8*)s);
3822                 }
3823             }
3824             if (PL_doextract) {
3825                 /* Incest with pod. */
3826 #ifdef PERL_MAD
3827                 if (PL_madskills)
3828                     sv_catsv(PL_thiswhite, PL_linestr);
3829 #endif
3830                 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3831                     sv_setpvs(PL_linestr, "");
3832                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3833                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3834                     PL_last_lop = PL_last_uni = NULL;
3835                     PL_doextract = FALSE;
3836                 }
3837             }
3838             incline(s);
3839         } while (PL_doextract);
3840         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3841         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3842             update_debugger_info(PL_linestr, NULL, 0);
3843         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3844         PL_last_lop = PL_last_uni = NULL;
3845         if (CopLINE(PL_curcop) == 1) {
3846             while (s < PL_bufend && isSPACE(*s))
3847                 s++;
3848             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3849                 s++;
3850 #ifdef PERL_MAD
3851             if (PL_madskills)
3852                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3853 #endif
3854             d = NULL;
3855             if (!PL_in_eval) {
3856                 if (*s == '#' && *(s+1) == '!')
3857                     d = s + 2;
3858 #ifdef ALTERNATE_SHEBANG
3859                 else {
3860                     static char const as[] = ALTERNATE_SHEBANG;
3861                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3862                         d = s + (sizeof(as) - 1);
3863                 }
3864 #endif /* ALTERNATE_SHEBANG */
3865             }
3866             if (d) {
3867                 char *ipath;
3868                 char *ipathend;
3869
3870                 while (isSPACE(*d))
3871                     d++;
3872                 ipath = d;
3873                 while (*d && !isSPACE(*d))
3874                     d++;
3875                 ipathend = d;
3876
3877 #ifdef ARG_ZERO_IS_SCRIPT
3878                 if (ipathend > ipath) {
3879                     /*
3880                      * HP-UX (at least) sets argv[0] to the script name,
3881                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3882                      * at least, set argv[0] to the basename of the Perl
3883                      * interpreter. So, having found "#!", we'll set it right.
3884                      */
3885                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3886                                                     SVt_PV)); /* $^X */
3887                     assert(SvPOK(x) || SvGMAGICAL(x));
3888                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3889                         sv_setpvn(x, ipath, ipathend - ipath);
3890                         SvSETMAGIC(x);
3891                     }
3892                     else {
3893                         STRLEN blen;
3894                         STRLEN llen;
3895                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3896                         const char * const lstart = SvPV_const(x,llen);
3897                         if (llen < blen) {
3898                             bstart += blen - llen;
3899                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3900                                 sv_setpvn(x, ipath, ipathend - ipath);
3901                                 SvSETMAGIC(x);
3902                             }
3903                         }
3904                     }
3905                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3906                 }
3907 #endif /* ARG_ZERO_IS_SCRIPT */
3908
3909                 /*
3910                  * Look for options.
3911                  */
3912                 d = instr(s,"perl -");
3913                 if (!d) {
3914                     d = instr(s,"perl");
3915 #if defined(DOSISH)
3916                     /* avoid getting into infinite loops when shebang
3917                      * line contains "Perl" rather than "perl" */
3918                     if (!d) {
3919                         for (d = ipathend-4; d >= ipath; --d) {
3920                             if ((*d == 'p' || *d == 'P')
3921                                 && !ibcmp(d, "perl", 4))
3922                             {
3923                                 break;
3924                             }
3925                         }
3926                         if (d < ipath)
3927                             d = NULL;
3928                     }
3929 #endif
3930                 }
3931 #ifdef ALTERNATE_SHEBANG
3932                 /*
3933                  * If the ALTERNATE_SHEBANG on this system starts with a
3934                  * character that can be part of a Perl expression, then if
3935                  * we see it but not "perl", we're probably looking at the
3936                  * start of Perl code, not a request to hand off to some
3937                  * other interpreter.  Similarly, if "perl" is there, but
3938                  * not in the first 'word' of the line, we assume the line
3939                  * contains the start of the Perl program.
3940                  */
3941                 if (d && *s != '#') {
3942                     const char *c = ipath;
3943                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3944                         c++;
3945                     if (c < d)
3946                         d = NULL;       /* "perl" not in first word; ignore */
3947                     else
3948                         *s = '#';       /* Don't try to parse shebang line */
3949                 }
3950 #endif /* ALTERNATE_SHEBANG */
3951 #ifndef MACOS_TRADITIONAL
3952                 if (!d &&
3953                     *s == '#' &&
3954                     ipathend > ipath &&
3955                     !PL_minus_c &&
3956                     !instr(s,"indir") &&
3957                     instr(PL_origargv[0],"perl"))
3958                 {
3959                     dVAR;
3960                     char **newargv;
3961
3962                     *ipathend = '\0';
3963                     s = ipathend + 1;
3964                     while (s < PL_bufend && isSPACE(*s))
3965                         s++;
3966                     if (s < PL_bufend) {
3967                         Newxz(newargv,PL_origargc+3,char*);
3968                         newargv[1] = s;
3969                         while (s < PL_bufend && !isSPACE(*s))
3970                             s++;
3971                         *s = '\0';
3972                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3973                     }
3974                     else
3975                         newargv = PL_origargv;
3976                     newargv[0] = ipath;
3977                     PERL_FPU_PRE_EXEC
3978                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3979                     PERL_FPU_POST_EXEC
3980                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3981                 }
3982 #endif
3983                 if (d) {
3984                     while (*d && !isSPACE(*d))
3985                         d++;
3986                     while (SPACE_OR_TAB(*d))
3987                         d++;
3988
3989                     if (*d++ == '-') {
3990                         const bool switches_done = PL_doswitches;
3991                         const U32 oldpdb = PL_perldb;
3992                         const bool oldn = PL_minus_n;
3993                         const bool oldp = PL_minus_p;
3994                         const char *d1 = d;
3995
3996                         do {
3997                             if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
3998                                 const char * const m = d1;
3999                                 while (*d1 && !isSPACE(*d1))
4000                                     d1++;
4001                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4002                                       (int)(d1 - m), m);
4003                             }
4004                             d1 = moreswitches(d1);
4005                         } while (d1);
4006                         if (PL_doswitches && !switches_done) {
4007                             int argc = PL_origargc;
4008                             char **argv = PL_origargv;
4009                             do {
4010                                 argc--,argv++;
4011                             } while (argc && argv[0][0] == '-' && argv[0][1]);
4012                             init_argv_symbols(argc,argv);
4013                         }
4014                         if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4015                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4016                               /* if we have already added "LINE: while (<>) {",
4017                                  we must not do it again */
4018                         {
4019                             sv_setpvs(PL_linestr, "");
4020                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4021                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4022                             PL_last_lop = PL_last_uni = NULL;
4023                             PL_preambled = FALSE;
4024                             if (PERLDB_LINE || PERLDB_SAVESRC)
4025                                 (void)gv_fetchfile(PL_origfilename);
4026                             goto retry;
4027                         }
4028                     }
4029                 }
4030             }
4031         }
4032         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4033             PL_bufptr = s;
4034             PL_lex_state = LEX_FORMLINE;
4035             return yylex();
4036         }
4037         goto retry;
4038     case '\r':
4039 #ifdef PERL_STRICT_CR
4040         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4041         Perl_croak(aTHX_
4042       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4043 #endif
4044     case ' ': case '\t': case '\f': case 013:
4045 #ifdef MACOS_TRADITIONAL
4046     case '\312':
4047 #endif
4048 #ifdef PERL_MAD
4049         PL_realtokenstart = -1;
4050         if (!PL_thiswhite)
4051             PL_thiswhite = newSVpvs("");
4052         sv_catpvn(PL_thiswhite, s, 1);
4053 #endif
4054         s++;
4055         goto retry;
4056     case '#':
4057     case '\n':
4058 #ifdef PERL_MAD
4059         PL_realtokenstart = -1;
4060         if (PL_madskills)
4061             PL_faketokens = 0;
4062 #endif
4063         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4064             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4065                 /* handle eval qq[#line 1 "foo"\n ...] */
4066                 CopLINE_dec(PL_curcop);
4067                 incline(s);
4068             }
4069             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4070                 s = SKIPSPACE0(s);
4071                 if (!PL_in_eval || PL_rsfp)
4072                     incline(s);
4073             }
4074             else {
4075                 d = s;
4076                 while (d < PL_bufend && *d != '\n')
4077                     d++;
4078                 if (d < PL_bufend)
4079                     d++;
4080                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4081                   Perl_croak(aTHX_ "panic: input overflow");
4082 #ifdef PERL_MAD
4083                 if (PL_madskills)
4084                     PL_thiswhite = newSVpvn(s, d - s);
4085 #endif
4086                 s = d;
4087                 incline(s);
4088             }
4089             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4090                 PL_bufptr = s;
4091                 PL_lex_state = LEX_FORMLINE;
4092                 return yylex();
4093             }
4094         }
4095         else {
4096 #ifdef PERL_MAD
4097             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4098                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4099                     PL_faketokens = 0;
4100                     s = SKIPSPACE0(s);
4101                     TOKEN(PEG); /* make sure any #! line is accessible */
4102                 }
4103                 s = SKIPSPACE0(s);
4104             }
4105             else {
4106 /*              if (PL_madskills && PL_lex_formbrack) { */
4107                     d = s;
4108                     while (d < PL_bufend && *d != '\n')
4109                         d++;
4110                     if (d < PL_bufend)
4111                         d++;
4112                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4113                       Perl_croak(aTHX_ "panic: input overflow");
4114                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4115                         if (!PL_thiswhite)
4116                             PL_thiswhite = newSVpvs("");
4117                         if (CopLINE(PL_curcop) == 1) {
4118                             sv_setpvs(PL_thiswhite, "");
4119                             PL_faketokens = 0;
4120                         }
4121                         sv_catpvn(PL_thiswhite, s, d - s);
4122                     }
4123                     s = d;
4124 /*              }
4125                 *s = '\0';
4126                 PL_bufend = s; */
4127             }
4128 #else
4129             *s = '\0';
4130             PL_bufend = s;
4131 #endif
4132         }
4133         goto retry;
4134     case '-':
4135         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4136             I32 ftst = 0;
4137             char tmp;
4138
4139             s++;
4140             PL_bufptr = s;
4141             tmp = *s++;
4142
4143             while (s < PL_bufend && SPACE_OR_TAB(*s))
4144                 s++;
4145
4146             if (strnEQ(s,"=>",2)) {
4147                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4148                 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4149                 OPERATOR('-');          /* unary minus */
4150             }
4151             PL_last_uni = PL_oldbufptr;
4152             switch (tmp) {
4153             case 'r': ftst = OP_FTEREAD;        break;
4154             case 'w': ftst = OP_FTEWRITE;       break;
4155             case 'x': ftst = OP_FTEEXEC;        break;
4156             case 'o': ftst = OP_FTEOWNED;       break;
4157             case 'R': ftst = OP_FTRREAD;        break;
4158             case 'W': ftst = OP_FTRWRITE;       break;
4159             case 'X': ftst = OP_FTREXEC;        break;
4160             case 'O': ftst = OP_FTROWNED;       break;
4161             case 'e': ftst = OP_FTIS;           break;
4162             case 'z': ftst = OP_FTZERO;         break;
4163             case 's': ftst = OP_FTSIZE;         break;
4164             case 'f': ftst = OP_FTFILE;         break;
4165             case 'd': ftst = OP_FTDIR;          break;
4166             case 'l': ftst = OP_FTLINK;         break;
4167             case 'p': ftst = OP_FTPIPE;         break;
4168             case 'S': ftst = OP_FTSOCK;         break;
4169             case 'u': ftst = OP_FTSUID;         break;
4170             case 'g': ftst = OP_FTSGID;         break;
4171             case 'k': ftst = OP_FTSVTX;         break;
4172             case 'b': ftst = OP_FTBLK;          break;
4173             case 'c': ftst = OP_FTCHR;          break;
4174             case 't': ftst = OP_FTTTY;          break;
4175             case 'T': ftst = OP_FTTEXT;         break;
4176             case 'B': ftst = OP_FTBINARY;       break;
4177             case 'M': case 'A': case 'C':
4178                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4179                 switch (tmp) {
4180                 case 'M': ftst = OP_FTMTIME;    break;
4181                 case 'A': ftst = OP_FTATIME;    break;
4182                 case 'C': ftst = OP_FTCTIME;    break;
4183                 default:                        break;
4184                 }
4185                 break;
4186             default:
4187                 break;
4188             }
4189             if (ftst) {
4190                 PL_last_lop_op = (OPCODE)ftst;
4191                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4192                         "### Saw file test %c\n", (int)tmp);
4193                 } );
4194                 FTST(ftst);
4195             }
4196             else {
4197                 /* Assume it was a minus followed by a one-letter named
4198                  * subroutine call (or a -bareword), then. */
4199                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4200                         "### '-%c' looked like a file test but was not\n",
4201                         (int) tmp);
4202                 } );
4203                 s = --PL_bufptr;
4204             }
4205         }
4206         {
4207             const char tmp = *s++;
4208             if (*s == tmp) {
4209                 s++;
4210                 if (PL_expect == XOPERATOR)
4211                     TERM(POSTDEC);
4212                 else
4213                     OPERATOR(PREDEC);
4214             }
4215             else if (*s == '>') {
4216                 s++;
4217                 s = SKIPSPACE1(s);
4218                 if (isIDFIRST_lazy_if(s,UTF)) {
4219                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4220                     TOKEN(ARROW);
4221                 }
4222                 else if (*s == '$')
4223                     OPERATOR(ARROW);
4224                 else
4225                     TERM(ARROW);
4226             }
4227             if (PL_expect == XOPERATOR)
4228                 Aop(OP_SUBTRACT);
4229             else {
4230                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4231                     check_uni();
4232                 OPERATOR('-');          /* unary minus */
4233             }
4234         }
4235
4236     case '+':
4237         {
4238             const char tmp = *s++;
4239             if (*s == tmp) {
4240                 s++;
4241                 if (PL_expect == XOPERATOR)
4242                     TERM(POSTINC);
4243                 else
4244                     OPERATOR(PREINC);
4245             }
4246             if (PL_expect == XOPERATOR)
4247                 Aop(OP_ADD);
4248             else {
4249                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4250                     check_uni();
4251                 OPERATOR('+');
4252             }
4253         }
4254
4255     case '*':
4256         if (PL_expect != XOPERATOR) {
4257             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4258             PL_expect = XOPERATOR;
4259             force_ident(PL_tokenbuf, '*');
4260             if (!*PL_tokenbuf)
4261                 PREREF('*');
4262             TERM('*');
4263         }
4264         s++;
4265         if (*s == '*') {
4266             s++;
4267             PWop(OP_POW);
4268         }
4269         Mop(OP_MULTIPLY);
4270
4271     case '%':
4272         if (PL_expect == XOPERATOR) {
4273             ++s;
4274             Mop(OP_MODULO);
4275         }
4276         PL_tokenbuf[0] = '%';
4277         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4278                 sizeof PL_tokenbuf - 1, FALSE);
4279         if (!PL_tokenbuf[1]) {
4280             PREREF('%');
4281         }
4282         PL_pending_ident = '%';
4283         TERM('%');
4284
4285     case '^':
4286         s++;
4287         BOop(OP_BIT_XOR);
4288     case '[':
4289         PL_lex_brackets++;
4290         {
4291             const char tmp = *s++;
4292             OPERATOR(tmp);
4293         }
4294     case '~':
4295         if (s[1] == '~'
4296             && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4297         {
4298             s += 2;
4299             Eop(OP_SMARTMATCH);
4300         }
4301     case ',':
4302         {
4303             const char tmp = *s++;
4304             OPERATOR(tmp);
4305         }
4306     case ':':
4307         if (s[1] == ':') {
4308             len = 0;
4309             goto just_a_word_zero_gv;
4310         }
4311         s++;
4312         switch (PL_expect) {
4313             OP *attrs;
4314 #ifdef PERL_MAD
4315             I32 stuffstart;
4316 #endif
4317         case XOPERATOR:
4318             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4319                 break;
4320             PL_bufptr = s;      /* update in case we back off */
4321             goto grabattrs;
4322         case XATTRBLOCK:
4323             PL_expect = XBLOCK;
4324             goto grabattrs;
4325         case XATTRTERM:
4326             PL_expect = XTERMBLOCK;
4327          grabattrs:
4328 #ifdef PERL_MAD
4329             stuffstart = s - SvPVX(PL_linestr) - 1;
4330 #endif
4331             s = PEEKSPACE(s);
4332             attrs = NULL;
4333             while (isIDFIRST_lazy_if(s,UTF)) {
4334                 I32 tmp;
4335                 SV *sv;
4336                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4337                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4338                     if (tmp < 0) tmp = -tmp;
4339                     switch (tmp) {
4340                     case KEY_or:
4341                     case KEY_and:
4342                     case KEY_for:
4343                     case KEY_foreach:
4344                     case KEY_unless:
4345                     case KEY_if:
4346                     case KEY_while:
4347                     case KEY_until:
4348                         goto got_attrs;
4349                     default:
4350                         break;
4351                     }
4352                 }
4353                 sv = newSVpvn(s, len);
4354                 if (*d == '(') {
4355                     d = scan_str(d,TRUE,TRUE);
4356                     if (!d) {
4357                         /* MUST advance bufptr here to avoid bogus
4358                            "at end of line" context messages from yyerror().
4359                          */
4360                         PL_bufptr = s + len;
4361                         yyerror("Unterminated attribute parameter in attribute list");
4362                         if (attrs)
4363                             op_free(attrs);
4364                         sv_free(sv);
4365                         return REPORT(0);       /* EOF indicator */
4366                     }
4367                 }
4368                 if (PL_lex_stuff) {
4369                     sv_catsv(sv, PL_lex_stuff);
4370                     attrs = append_elem(OP_LIST, attrs,
4371                                         newSVOP(OP_CONST, 0, sv));
4372                     SvREFCNT_dec(PL_lex_stuff);
4373                     PL_lex_stuff = NULL;
4374                 }
4375                 else {
4376                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4377                         sv_free(sv);
4378                         if (PL_in_my == KEY_our) {
4379                             deprecate(":unique");
4380                         }
4381                         else
4382                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4383                     }
4384
4385                     /* NOTE: any CV attrs applied here need to be part of
4386                        the CVf_BUILTIN_ATTRS define in cv.h! */
4387                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4388                         sv_free(sv);
4389                         CvLVALUE_on(PL_compcv);
4390                     }
4391                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4392                         sv_free(sv);
4393                         deprecate(":locked");
4394                     }
4395                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4396                         sv_free(sv);
4397                         CvMETHOD_on(PL_compcv);
4398                     }
4399                     /* After we've set the flags, it could be argued that
4400                        we don't need to do the attributes.pm-based setting
4401                        process, and shouldn't bother appending recognized
4402                        flags.  To experiment with that, uncomment the
4403                        following "else".  (Note that's already been
4404                        uncommented.  That keeps the above-applied built-in
4405                        attributes from being intercepted (and possibly
4406                        rejected) by a package's attribute routines, but is
4407                        justified by the performance win for the common case
4408                        of applying only built-in attributes.) */
4409                     else
4410                         attrs = append_elem(OP_LIST, attrs,
4411                                             newSVOP(OP_CONST, 0,
4412                                                     sv));
4413                 }
4414                 s = PEEKSPACE(d);
4415                 if (*s == ':' && s[1] != ':')
4416                     s = PEEKSPACE(s+1);
4417                 else if (s == d)
4418                     break;      /* require real whitespace or :'s */
4419                 /* XXX losing whitespace on sequential attributes here */
4420             }
4421             {
4422                 const char tmp
4423                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4424                 if (*s != ';' && *s != '}' && *s != tmp
4425                     && (tmp != '=' || *s != ')')) {
4426                     const char q = ((*s == '\'') ? '"' : '\'');
4427                     /* If here for an expression, and parsed no attrs, back
4428                        off. */
4429                     if (tmp == '=' && !attrs) {
4430                         s = PL_bufptr;
4431                         break;
4432                     }
4433                     /* MUST advance bufptr here to avoid bogus "at end of line"
4434                        context messages from yyerror().
4435                     */
4436                     PL_bufptr = s;
4437                     yyerror( (const char *)
4438                              (*s
4439                               ? Perl_form(aTHX_ "Invalid separator character "
4440                                           "%c%c%c in attribute list", q, *s, q)
4441                               : "Unterminated attribute list" ) );
4442                     if (attrs)
4443                         op_free(attrs);
4444                     OPERATOR(':');
4445                 }
4446             }
4447         got_attrs:
4448             if (attrs) {
4449                 start_force(PL_curforce);
4450                 NEXTVAL_NEXTTOKE.opval = attrs;
4451                 CURMAD('_', PL_nextwhite);
4452                 force_next(THING);
4453             }
4454 #ifdef PERL_MAD
4455             if (PL_madskills) {
4456                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4457                                      (s - SvPVX(PL_linestr)) - stuffstart);
4458             }
4459 #endif
4460             TOKEN(COLONATTR);
4461         }
4462         OPERATOR(':');
4463     case '(':
4464         s++;
4465         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4466             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4467         else
4468             PL_expect = XTERM;
4469         s = SKIPSPACE1(s);
4470         TOKEN('(');
4471     case ';':
4472         CLINE;
4473         {
4474             const char tmp = *s++;
4475             OPERATOR(tmp);
4476         }
4477     case ')':
4478         {
4479             const char tmp = *s++;
4480             s = SKIPSPACE1(s);
4481             if (*s == '{')
4482                 PREBLOCK(tmp);
4483             TERM(tmp);
4484         }
4485     case ']':
4486         s++;
4487         if (PL_lex_brackets <= 0)
4488             yyerror("Unmatched right square bracket");
4489         else
4490             --PL_lex_brackets;
4491         if (PL_lex_state == LEX_INTERPNORMAL) {
4492             if (PL_lex_brackets == 0) {
4493                 if (*s == '-' && s[1] == '>')
4494                     PL_lex_state = LEX_INTERPENDMAYBE;
4495                 else if (*s != '[' && *s != '{')
4496                     PL_lex_state = LEX_INTERPEND;
4497             }
4498         }
4499         TERM(']');
4500     case '{':
4501       leftbracket:
4502         s++;
4503         if (PL_lex_brackets > 100) {
4504             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4505         }
4506         switch (PL_expect) {
4507         case XTERM:
4508             if (PL_lex_formbrack) {
4509                 s--;
4510                 PRETERMBLOCK(DO);
4511             }
4512             if (PL_oldoldbufptr == PL_last_lop)
4513                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4514             else
4515                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4516             OPERATOR(HASHBRACK);
4517         case XOPERATOR:
4518             while (s < PL_bufend && SPACE_OR_TAB(*s))
4519                 s++;
4520             d = s;
4521             PL_tokenbuf[0] = '\0';
4522             if (d < PL_bufend && *d == '-') {
4523                 PL_tokenbuf[0] = '-';
4524                 d++;
4525                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4526                     d++;
4527             }
4528             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4529                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4530                               FALSE, &len);
4531                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4532                     d++;
4533                 if (*d == '}') {
4534                     const char minus = (PL_tokenbuf[0] == '-');
4535                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4536                     if (minus)
4537                         force_next('-');
4538                 }
4539             }
4540             /* FALL THROUGH */
4541         case XATTRBLOCK:
4542         case XBLOCK:
4543             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4544             PL_expect = XSTATE;
4545             break;
4546         case XATTRTERM:
4547         case XTERMBLOCK:
4548             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4549             PL_expect = XSTATE;
4550             break;
4551         default: {
4552                 const char *t;
4553                 if (PL_oldoldbufptr == PL_last_lop)
4554                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4555                 else
4556                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4557                 s = SKIPSPACE1(s);
4558                 if (*s == '}') {
4559                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4560                         PL_expect = XTERM;
4561                         /* This hack is to get the ${} in the message. */
4562                         PL_bufptr = s+1;
4563                         yyerror("syntax error");
4564                         break;
4565                     }
4566                     OPERATOR(HASHBRACK);
4567                 }
4568                 /* This hack serves to disambiguate a pair of curlies
4569                  * as being a block or an anon hash.  Normally, expectation
4570                  * determines that, but in cases where we're not in a
4571                  * position to expect anything in particular (like inside
4572                  * eval"") we have to resolve the ambiguity.  This code
4573                  * covers the case where the first term in the curlies is a
4574                  * quoted string.  Most other cases need to be explicitly
4575                  * disambiguated by prepending a "+" before the opening
4576                  * curly in order to force resolution as an anon hash.
4577                  *
4578                  * XXX should probably propagate the outer expectation
4579                  * into eval"" to rely less on this hack, but that could
4580                  * potentially break current behavior of eval"".
4581                  * GSAR 97-07-21
4582                  */
4583                 t = s;
4584                 if (*s == '\'' || *s == '"' || *s == '`') {
4585                     /* common case: get past first string, handling escapes */
4586                     for (t++; t < PL_bufend && *t != *s;)
4587                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4588                             t++;
4589                     t++;
4590                 }
4591                 else if (*s == 'q') {
4592                     if (++t < PL_bufend
4593                         && (!isALNUM(*t)
4594                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4595                                 && !isALNUM(*t))))
4596                     {
4597                         /* skip q//-like construct */
4598                         const char *tmps;
4599                         char open, close, term;
4600                         I32 brackets = 1;
4601
4602                         while (t < PL_bufend && isSPACE(*t))
4603                             t++;
4604                         /* check for q => */
4605                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4606                             OPERATOR(HASHBRACK);
4607                         }
4608                         term = *t;
4609                         open = term;
4610                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4611                             term = tmps[5];
4612                         close = term;
4613                         if (open == close)
4614                             for (t++; t < PL_bufend; t++) {
4615                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4616                                     t++;
4617                                 else if (*t == open)
4618                                     break;
4619                             }
4620                         else {
4621                             for (t++; t < PL_bufend; t++) {
4622                                 if (*t == '\\' && t+1 < PL_bufend)
4623                                     t++;
4624                                 else if (*t == close && --brackets <= 0)
4625                                     break;
4626                                 else if (*t == open)
4627                                     brackets++;
4628                             }
4629                         }
4630                         t++;
4631                     }
4632                     else
4633                         /* skip plain q word */
4634                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4635                              t += UTF8SKIP(t);
4636                 }
4637                 else if (isALNUM_lazy_if(t,UTF)) {
4638                     t += UTF8SKIP(t);
4639                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4640                          t += UTF8SKIP(t);
4641                 }
4642                 while (t < PL_bufend && isSPACE(*t))
4643                     t++;
4644                 /* if comma follows first term, call it an anon hash */
4645                 /* XXX it could be a comma expression with loop modifiers */
4646                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4647                                    || (*t == '=' && t[1] == '>')))
4648                     OPERATOR(HASHBRACK);
4649                 if (PL_expect == XREF)
4650                     PL_expect = XTERM;
4651                 else {
4652                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4653                     PL_expect = XSTATE;
4654                 }
4655             }
4656             break;
4657         }
4658         pl_yylval.ival = CopLINE(PL_curcop);
4659         if (isSPACE(*s) || *s == '#')
4660             PL_copline = NOLINE;   /* invalidate current command line number */
4661         TOKEN('{');
4662     case '}':
4663       rightbracket:
4664         s++;
4665         if (PL_lex_brackets <= 0)
4666             yyerror("Unmatched right curly bracket");
4667         else
4668             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4669         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4670             PL_lex_formbrack = 0;
4671         if (PL_lex_state == LEX_INTERPNORMAL) {
4672             if (PL_lex_brackets == 0) {
4673                 if (PL_expect & XFAKEBRACK) {
4674                     PL_expect &= XENUMMASK;
4675                     PL_lex_state = LEX_INTERPEND;
4676                     PL_bufptr = s;
4677 #if 0
4678                     if (PL_madskills) {
4679                         if (!PL_thiswhite)
4680                             PL_thiswhite = newSVpvs("");
4681                         sv_catpvs(PL_thiswhite,"}");
4682                     }
4683 #endif
4684                     return yylex();     /* ignore fake brackets */
4685                 }
4686                 if (*s == '-' && s[1] == '>')
4687                     PL_lex_state = LEX_INTERPENDMAYBE;
4688                 else if (*s != '[' && *s != '{')
4689                     PL_lex_state = LEX_INTERPEND;
4690             }
4691         }
4692         if (PL_expect & XFAKEBRACK) {
4693             PL_expect &= XENUMMASK;
4694             PL_bufptr = s;
4695             return yylex();             /* ignore fake brackets */
4696         }
4697         start_force(PL_curforce);
4698         if (PL_madskills) {
4699             curmad('X', newSVpvn(s-1,1));
4700             CURMAD('_', PL_thiswhite);
4701         }
4702         force_next('}');
4703 #ifdef PERL_MAD
4704         if (!PL_thistoken)
4705             PL_thistoken = newSVpvs("");
4706 #endif
4707         TOKEN(';');
4708     case '&':
4709         s++;
4710         if (*s++ == '&')
4711             AOPERATOR(ANDAND);
4712         s--;
4713         if (PL_expect == XOPERATOR) {
4714             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4715                 && isIDFIRST_lazy_if(s,UTF))
4716             {
4717                 CopLINE_dec(PL_curcop);
4718                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4719                 CopLINE_inc(PL_curcop);
4720             }
4721             BAop(OP_BIT_AND);
4722         }
4723
4724         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4725         if (*PL_tokenbuf) {
4726             PL_expect = XOPERATOR;
4727             force_ident(PL_tokenbuf, '&');
4728         }
4729         else
4730             PREREF('&');
4731         pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4732         TERM('&');
4733
4734     case '|':
4735         s++;
4736         if (*s++ == '|')
4737             AOPERATOR(OROR);
4738         s--;
4739         BOop(OP_BIT_OR);
4740     case '=':
4741         s++;
4742         {
4743             const char tmp = *s++;
4744             if (tmp == '=')
4745                 Eop(OP_EQ);
4746             if (tmp == '>')
4747                 OPERATOR(',');
4748             if (tmp == '~')
4749                 PMop(OP_MATCH);
4750             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4751                 && strchr("+-*/%.^&|<",tmp))
4752                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4753                             "Reversed %c= operator",(int)tmp);
4754             s--;
4755             if (PL_expect == XSTATE && isALPHA(tmp) &&
4756                 (s == PL_linestart+1 || s[-2] == '\n') )
4757                 {
4758                     if (PL_in_eval && !PL_rsfp) {
4759                         d = PL_bufend;
4760                         while (s < d) {
4761                             if (*s++ == '\n') {
4762                                 incline(s);
4763                                 if (strnEQ(s,"=cut",4)) {
4764                                     s = strchr(s,'\n');
4765                                     if (s)
4766                                         s++;
4767                                     else
4768                                         s = d;
4769                                     incline(s);
4770                                     goto retry;
4771                                 }
4772                             }
4773                         }
4774                         goto retry;
4775                     }
4776 #ifdef PERL_MAD
4777                     if (PL_madskills) {
4778                         if (!PL_thiswhite)
4779                             PL_thiswhite = newSVpvs("");
4780                         sv_catpvn(PL_thiswhite, PL_linestart,
4781                                   PL_bufend - PL_linestart);
4782                     }
4783 #endif
4784                     s = PL_bufend;
4785                     PL_doextract = TRUE;
4786                     goto retry;
4787                 }
4788         }
4789         if (PL_lex_brackets < PL_lex_formbrack) {
4790             const char *t = s;
4791 #ifdef PERL_STRICT_CR
4792             while (SPACE_OR_TAB(*t))
4793 #else
4794             while (SPACE_OR_TAB(*t) || *t == '\r')
4795 #endif
4796                 t++;
4797             if (*t == '\n' || *t == '#') {
4798                 s--;
4799                 PL_expect = XBLOCK;
4800                 goto leftbracket;
4801             }
4802         }
4803         pl_yylval.ival = 0;
4804         OPERATOR(ASSIGNOP);
4805     case '!':
4806         if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
4807             s += 3;
4808             LOP(OP_DIE,XTERM);
4809         }
4810         s++;
4811         {
4812             const char tmp = *s++;
4813             if (tmp == '=') {
4814                 /* was this !=~ where !~ was meant?
4815                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4816
4817                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4818                     const char *t = s+1;
4819
4820                     while (t < PL_bufend && isSPACE(*t))
4821                         ++t;
4822
4823                     if (*t == '/' || *t == '?' ||
4824                         ((*t == 'm' || *t == 's' || *t == 'y')
4825                          && !isALNUM(t[1])) ||
4826                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4827                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4828                                     "!=~ should be !~");
4829                 }
4830                 Eop(OP_NE);
4831             }
4832             if (tmp == '~')
4833                 PMop(OP_NOT);
4834         }
4835         s--;
4836         OPERATOR('!');
4837     case '<':
4838         if (PL_expect != XOPERATOR) {
4839             if (s[1] != '<' && !strchr(s,'>'))
4840                 check_uni();
4841             if (s[1] == '<')
4842                 s = scan_heredoc(s);
4843             else
4844                 s = scan_inputsymbol(s);
4845             TERM(sublex_start());
4846         }
4847         s++;
4848         {
4849             char tmp = *s++;
4850             if (tmp == '<')
4851                 SHop(OP_LEFT_SHIFT);
4852             if (tmp == '=') {
4853                 tmp = *s++;
4854                 if (tmp == '>')
4855                     Eop(OP_NCMP);
4856                 s--;
4857                 Rop(OP_LE);
4858             }
4859         }
4860         s--;
4861         Rop(OP_LT);
4862     case '>':
4863         s++;
4864         {
4865             const char tmp = *s++;
4866             if (tmp == '>')
4867                 SHop(OP_RIGHT_SHIFT);
4868             else if (tmp == '=')
4869                 Rop(OP_GE);
4870         }
4871         s--;
4872         Rop(OP_GT);
4873
4874     case '$':
4875         CLINE;
4876
4877         if (PL_expect == XOPERATOR) {
4878             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4879                 PL_expect = XTERM;
4880                 deprecate_old(commaless_variable_list);
4881                 return REPORT(','); /* grandfather non-comma-format format */
4882             }
4883         }
4884
4885         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4886             PL_tokenbuf[0] = '@';
4887             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4888                            sizeof PL_tokenbuf - 1, FALSE);
4889             if (PL_expect == XOPERATOR)
4890                 no_op("Array length", s);
4891             if (!PL_tokenbuf[1])
4892                 PREREF(DOLSHARP);
4893             PL_expect = XOPERATOR;
4894             PL_pending_ident = '#';
4895             TOKEN(DOLSHARP);
4896         }
4897
4898         PL_tokenbuf[0] = '$';
4899         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4900                        sizeof PL_tokenbuf - 1, FALSE);
4901         if (PL_expect == XOPERATOR)
4902             no_op("Scalar", s);
4903         if (!PL_tokenbuf[1]) {
4904             if (s == PL_bufend)
4905                 yyerror("Final $ should be \\$ or $name");
4906             PREREF('$');
4907         }
4908
4909         /* This kludge not intended to be bulletproof. */
4910         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4911             pl_yylval.opval = newSVOP(OP_CONST, 0,
4912                                    newSViv(CopARYBASE_get(&PL_compiling)));
4913             pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4914             TERM(THING);
4915         }
4916
4917         d = s;
4918         {
4919             const char tmp = *s;
4920             if (PL_lex_state == LEX_NORMAL)
4921                 s = SKIPSPACE1(s);
4922
4923             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4924                 && intuit_more(s)) {
4925                 if (*s == '[') {
4926                     PL_tokenbuf[0] = '@';
4927                     if (ckWARN(WARN_SYNTAX)) {
4928                         char *t = s+1;
4929
4930                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4931                             t++;
4932                         if (*t++ == ',') {
4933                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4934                             while (t < PL_bufend && *t != ']')
4935                                 t++;
4936                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4937                                         "Multidimensional syntax %.*s not supported",
4938                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4939                         }
4940                     }
4941                 }
4942                 else if (*s == '{') {
4943                     char *t;
4944                     PL_tokenbuf[0] = '%';
4945                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4946                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4947                         {
4948                             char tmpbuf[sizeof PL_tokenbuf];
4949                             do {
4950                                 t++;
4951                             } while (isSPACE(*t));
4952                             if (isIDFIRST_lazy_if(t,UTF)) {
4953                                 STRLEN len;
4954                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4955                                               &len);
4956                                 while (isSPACE(*t))
4957                                     t++;
4958                                 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4959                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4960                                                 "You need to quote \"%s\"",
4961                                                 tmpbuf);
4962                             }
4963                         }
4964                 }
4965             }
4966
4967             PL_expect = XOPERATOR;
4968             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4969                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4970                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4971                     PL_expect = XOPERATOR;
4972                 else if (strchr("$@\"'`q", *s))
4973                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4974                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4975                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4976                 else if (isIDFIRST_lazy_if(s,UTF)) {
4977                     char tmpbuf[sizeof PL_tokenbuf];
4978                     int t2;
4979                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4980                     if ((t2 = keyword(tmpbuf, len, 0))) {
4981                         /* binary operators exclude handle interpretations */
4982                         switch (t2) {
4983                         case -KEY_x:
4984                         case -KEY_eq:
4985                         case -KEY_ne:
4986                         case -KEY_gt:
4987                         case -KEY_lt:
4988                         case -KEY_ge:
4989                         case -KEY_le:
4990                         case -KEY_cmp:
4991                             break;
4992                         default:
4993                             PL_expect = XTERM;  /* e.g. print $fh length() */
4994                             break;
4995                         }
4996                     }
4997                     else {
4998                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4999                     }
5000                 }
5001                 else if (isDIGIT(*s))
5002                     PL_expect = XTERM;          /* e.g. print $fh 3 */
5003                 else if (*s == '.' && isDIGIT(s[1]))
5004                     PL_expect = XTERM;          /* e.g. print $fh .3 */
5005                 else if ((*s == '?' || *s == '-' || *s == '+')
5006                          && !isSPACE(s[1]) && s[1] != '=')
5007                     PL_expect = XTERM;          /* e.g. print $fh -1 */
5008                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5009                          && s[1] != '/')
5010                     PL_expect = XTERM;          /* e.g. print $fh /.../
5011                                                    XXX except DORDOR operator
5012                                                 */
5013                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5014                          && s[2] != '=')
5015                     PL_expect = XTERM;          /* print $fh <<"EOF" */
5016             }
5017         }
5018         PL_pending_ident = '$';
5019         TOKEN('$');
5020
5021     case '@':
5022         if (PL_expect == XOPERATOR)
5023             no_op("Array", s);
5024         PL_tokenbuf[0] = '@';
5025         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5026         if (!PL_tokenbuf[1]) {
5027             PREREF('@');
5028         }
5029         if (PL_lex_state == LEX_NORMAL)
5030             s = SKIPSPACE1(s);
5031         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5032             if (*s == '{')
5033                 PL_tokenbuf[0] = '%';
5034
5035             /* Warn about @ where they meant $. */
5036             if (*s == '[' || *s == '{') {
5037                 if (ckWARN(WARN_SYNTAX)) {
5038                     const char *t = s + 1;
5039                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5040                         t++;
5041                     if (*t == '}' || *t == ']') {
5042                         t++;
5043                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5044                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5045                             "Scalar value %.*s better written as $%.*s",
5046                             (int)(t-PL_bufptr), PL_bufptr,
5047                             (int)(t-PL_bufptr-1), PL_bufptr+1);
5048                     }
5049                 }
5050             }
5051         }
5052         PL_pending_ident = '@';
5053         TERM('@');
5054
5055      case '/':                  /* may be division, defined-or, or pattern */
5056         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5057             s += 2;
5058             AOPERATOR(DORDOR);
5059         }
5060      case '?':                  /* may either be conditional or pattern */
5061         if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
5062             s += 3;
5063             LOP(OP_WARN,XTERM);
5064         }
5065         if (PL_expect == XOPERATOR) {
5066              char tmp = *s++;
5067              if(tmp == '?') {
5068                 OPERATOR('?');
5069              }
5070              else {
5071                  tmp = *s++;
5072                  if(tmp == '/') {
5073                      /* A // operator. */
5074                     AOPERATOR(DORDOR);
5075                  }
5076                  else {
5077                      s--;
5078                      Mop(OP_DIVIDE);
5079                  }
5080              }
5081          }
5082          else {
5083              /* Disable warning on "study /blah/" */
5084              if (PL_oldoldbufptr == PL_last_uni
5085               && (*PL_last_uni != 's' || s - PL_last_uni < 5
5086                   || memNE(PL_last_uni, "study", 5)
5087                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
5088               ))
5089                  check_uni();
5090              s = scan_pat(s,OP_MATCH);
5091              TERM(sublex_start());
5092          }
5093
5094     case '.':
5095         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5096 #ifdef PERL_STRICT_CR
5097             && s[1] == '\n'
5098 #else
5099             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5100 #endif
5101             && (s == PL_linestart || s[-1] == '\n') )
5102         {
5103             PL_lex_formbrack = 0;
5104             PL_expect = XSTATE;
5105             goto rightbracket;
5106         }
5107         if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5108             s += 3;
5109             OPERATOR(YADAYADA);
5110         }
5111         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5112             char tmp = *s++;
5113             if (*s == tmp) {
5114                 s++;
5115                 if (*s == tmp) {
5116                     s++;
5117                     pl_yylval.ival = OPf_SPECIAL;
5118                 }
5119                 else
5120                     pl_yylval.ival = 0;
5121                 OPERATOR(DOTDOT);
5122             }
5123             if (PL_expect != XOPERATOR)
5124                 check_uni();
5125             Aop(OP_CONCAT);
5126         }
5127         /* FALL THROUGH */
5128     case '0': case '1': case '2': case '3': case '4':
5129     case '5': case '6': case '7': case '8': case '9':
5130         s = scan_num(s, &pl_yylval);
5131         DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5132         if (PL_expect == XOPERATOR)
5133             no_op("Number",s);
5134         TERM(THING);
5135
5136     case '\'':
5137         s = scan_str(s,!!PL_madskills,FALSE);
5138         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5139         if (PL_expect == XOPERATOR) {
5140             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5141                 PL_expect = XTERM;
5142                 deprecate_old(commaless_variable_list);
5143                 return REPORT(','); /* grandfather non-comma-format format */
5144             }
5145             else
5146                 no_op("String",s);
5147         }
5148         if (!s)
5149             missingterm(NULL);
5150         pl_yylval.ival = OP_CONST;
5151         TERM(sublex_start());
5152
5153     case '"':
5154         s = scan_str(s,!!PL_madskills,FALSE);
5155         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5156         if (PL_expect == XOPERATOR) {
5157             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5158                 PL_expect = XTERM;
5159                 deprecate_old(commaless_variable_list);
5160                 return REPORT(','); /* grandfather non-comma-format format */
5161             }
5162             else
5163                 no_op("String",s);
5164         }
5165         if (!s)
5166             missingterm(NULL);
5167         pl_yylval.ival = OP_CONST;
5168         /* FIXME. I think that this can be const if char *d is replaced by
5169            more localised variables.  */
5170         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5171             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5172                 pl_yylval.ival = OP_STRINGIFY;
5173                 break;
5174             }
5175         }
5176         TERM(sublex_start());
5177
5178     case '`':
5179         s = scan_str(s,!!PL_madskills,FALSE);
5180         DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5181         if (PL_expect == XOPERATOR)
5182             no_op("Backticks",s);
5183         if (!s)
5184             missingterm(NULL);
5185         readpipe_override();
5186         TERM(sublex_start());
5187
5188     case '\\':
5189         s++;
5190         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5191             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5192                         *s, *s);
5193         if (PL_expect == XOPERATOR)
5194             no_op("Backslash",s);
5195         OPERATOR(REFGEN);
5196
5197     case 'v':
5198         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5199             char *start = s + 2;
5200             while (isDIGIT(*start) || *start == '_')
5201                 start++;
5202             if (*start == '.' && isDIGIT(start[1])) {
5203                 s = scan_num(s, &pl_yylval);
5204                 TERM(THING);
5205             }
5206             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5207             else if (!isALPHA(*start) && (PL_expect == XTERM
5208                         || PL_expect == XREF || PL_expect == XSTATE
5209                         || PL_expect == XTERMORDORDOR)) {
5210                 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5211                 if (!gv) {
5212                     s = scan_num(s, &pl_yylval);
5213                     TERM(THING);
5214                 }
5215             }
5216         }
5217         goto keylookup;
5218     case 'x':
5219         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5220             s++;
5221             Mop(OP_REPEAT);
5222         }
5223         goto keylookup;
5224
5225     case '_':
5226     case 'a': case 'A':
5227     case 'b': case 'B':
5228     case 'c': case 'C':
5229     case 'd': case 'D':
5230     case 'e': case 'E':
5231     case 'f': case 'F':
5232     case 'g': case 'G':
5233     case 'h': case 'H':
5234     case 'i': case 'I':
5235     case 'j': case 'J':
5236     case 'k': case 'K':
5237     case 'l': case 'L':
5238     case 'm': case 'M':
5239     case 'n': case 'N':
5240     case 'o': case 'O':
5241     case 'p': case 'P':
5242     case 'q': case 'Q':
5243     case 'r': case 'R':
5244     case 's': case 'S':
5245     case 't': case 'T':
5246     case 'u': case 'U':
5247               case 'V':
5248     case 'w': case 'W':
5249               case 'X':
5250     case 'y': case 'Y':
5251     case 'z': case 'Z':
5252
5253       keylookup: {
5254         I32 tmp;
5255
5256         orig_keyword = 0;
5257         gv = NULL;
5258         gvp = NULL;
5259
5260         PL_bufptr = s;
5261         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5262
5263         /* Some keywords can be followed by any delimiter, including ':' */
5264         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5265                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5266                              (PL_tokenbuf[0] == 'q' &&
5267                               strchr("qwxr", PL_tokenbuf[1])))));
5268
5269         /* x::* is just a word, unless x is "CORE" */
5270         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5271             goto just_a_word;
5272
5273         d = s;
5274         while (d < PL_bufend && isSPACE(*d))
5275                 d++;    /* no comments skipped here, or s### is misparsed */
5276
5277         /* Is this a label? */
5278         if (!tmp && PL_expect == XSTATE
5279               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5280             s = d + 1;
5281             pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5282             CLINE;
5283             TOKEN(LABEL);
5284         }
5285
5286         /* Check for keywords */
5287         tmp = keyword(PL_tokenbuf, len, 0);
5288
5289         /* Is this a word before a => operator? */
5290         if (*d == '=' && d[1] == '>') {
5291             CLINE;
5292             pl_yylval.opval
5293                 = (OP*)newSVOP(OP_CONST, 0,
5294                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5295             pl_yylval.opval->op_private = OPpCONST_BARE;
5296             TERM(WORD);
5297         }
5298
5299         if (tmp < 0) {                  /* second-class keyword? */
5300             GV *ogv = NULL;     /* override (winner) */
5301             GV *hgv = NULL;     /* hidden (loser) */
5302             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5303                 CV *cv;
5304                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5305                     (cv = GvCVu(gv)))
5306                 {
5307                     if (GvIMPORTED_CV(gv))
5308                         ogv = gv;
5309                     else if (! CvMETHOD(cv))
5310                         hgv = gv;
5311                 }
5312                 if (!ogv &&
5313                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5314                     (gv = *gvp) && isGV_with_GP(gv) &&
5315                     GvCVu(gv) && GvIMPORTED_CV(gv))
5316                 {
5317                     ogv = gv;
5318                 }
5319             }
5320             if (ogv) {
5321                 orig_keyword = tmp;
5322                 tmp = 0;                /* overridden by import or by GLOBAL */
5323             }
5324             else if (gv && !gvp
5325                      && -tmp==KEY_lock  /* XXX generalizable kludge */
5326                      && GvCVu(gv))
5327             {
5328                 tmp = 0;                /* any sub overrides "weak" keyword */
5329             }
5330             else {                      /* no override */
5331                 tmp = -tmp;
5332                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5333                     Perl_warner(aTHX_ packWARN(WARN_MISC),
5334                             "dump() better written as CORE::dump()");
5335                 }
5336                 gv = NULL;
5337                 gvp = 0;
5338                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5339                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
5340                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5341                         "Ambiguous call resolved as CORE::%s(), %s",
5342                          GvENAME(hgv), "qualify as such or use &");
5343             }
5344         }
5345
5346       reserved_word:
5347         switch (tmp) {
5348
5349         default:                        /* not a keyword */
5350             /* Trade off - by using this evil construction we can pull the
5351                variable gv into the block labelled keylookup. If not, then
5352                we have to give it function scope so that the goto from the
5353                earlier ':' case doesn't bypass the initialisation.  */
5354             if (0) {
5355             just_a_word_zero_gv:
5356                 gv = NULL;
5357                 gvp = NULL;
5358                 orig_keyword = 0;
5359             }
5360           just_a_word: {
5361                 SV *sv;
5362                 int pkgname = 0;
5363                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5364                 CV *cv;
5365 #ifdef PERL_MAD
5366                 SV *nextPL_nextwhite = 0;
5367 #endif
5368
5369
5370                 /* Get the rest if it looks like a package qualifier */
5371
5372                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5373                     STRLEN morelen;
5374                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5375                                   TRUE, &morelen);
5376                     if (!morelen)
5377                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5378                                 *s == '\'' ? "'" : "::");
5379                     len += morelen;
5380                     pkgname = 1;
5381                 }
5382
5383                 if (PL_expect == XOPERATOR) {
5384                     if (PL_bufptr == PL_linestart) {
5385                         CopLINE_dec(PL_curcop);
5386                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5387                         CopLINE_inc(PL_curcop);
5388                     }
5389                     else
5390                         no_op("Bareword",s);
5391                 }
5392
5393                 /* Look for a subroutine with this name in current package,
5394                    unless name is "Foo::", in which case Foo is a bearword
5395                    (and a package name). */
5396
5397                 if (len > 2 && !PL_madskills &&
5398                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5399                 {
5400                     if (ckWARN(WARN_BAREWORD)
5401                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5402                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5403                             "Bareword \"%s\" refers to nonexistent package",
5404                              PL_tokenbuf);
5405                     len -= 2;
5406                     PL_tokenbuf[len] = '\0';
5407                     gv = NULL;
5408                     gvp = 0;
5409                 }
5410                 else {
5411                     if (!gv) {
5412                         /* Mustn't actually add anything to a symbol table.
5413                            But also don't want to "initialise" any placeholder
5414                            constants that might already be there into full
5415                            blown PVGVs with attached PVCV.  */
5416                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5417                                                GV_NOADD_NOINIT, SVt_PVCV);
5418                     }
5419                     len = 0;
5420                 }
5421
5422                 /* if we saw a global override before, get the right name */
5423
5424                 if (gvp) {
5425                     sv = newSVpvs("CORE::GLOBAL::");
5426                     sv_catpv(sv,PL_tokenbuf);
5427                 }
5428                 else {
5429                     /* If len is 0, newSVpv does strlen(), which is correct.
5430                        If len is non-zero, then it will be the true length,
5431                        and so the scalar will be created correctly.  */
5432                     sv = newSVpv(PL_tokenbuf,len);
5433                 }
5434 #ifdef PERL_MAD
5435                 if (PL_madskills && !PL_thistoken) {
5436                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5437                     PL_thistoken = newSVpvn(start,s - start);
5438                     PL_realtokenstart = s - SvPVX(PL_linestr);
5439                 }
5440 #endif
5441
5442                 /* Presume this is going to be a bareword of some sort. */
5443
5444                 CLINE;
5445                 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5446                 pl_yylval.opval->op_private = OPpCONST_BARE;
5447                 /* UTF-8 package name? */
5448                 if (UTF && !IN_BYTES &&
5449                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5450                     SvUTF8_on(sv);
5451
5452                 /* And if "Foo::", then that's what it certainly is. */
5453
5454                 if (len)
5455                     goto safe_bareword;
5456
5457                 /* Do the explicit type check so that we don't need to force
5458                    the initialisation of the symbol table to have a real GV.
5459                    Beware - gv may not really be a PVGV, cv may not really be
5460                    a PVCV, (because of the space optimisations that gv_init
5461                    understands) But they're true if for this symbol there is
5462                    respectively a typeglob and a subroutine.
5463                 */
5464                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5465                     /* Real typeglob, so get the real subroutine: */
5466                            ? GvCVu(gv)
5467                     /* A proxy for a subroutine in this package? */
5468                            : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5469                     : NULL;
5470
5471                 /* See if it's the indirect object for a list operator. */
5472
5473                 if (PL_oldoldbufptr &&
5474                     PL_oldoldbufptr < PL_bufptr &&
5475                     (PL_oldoldbufptr == PL_last_lop
5476                      || PL_oldoldbufptr == PL_last_uni) &&
5477                     /* NO SKIPSPACE BEFORE HERE! */
5478                     (PL_expect == XREF ||
5479                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5480                 {
5481                     bool immediate_paren = *s == '(';
5482
5483                     /* (Now we can afford to cross potential line boundary.) */
5484                     s = SKIPSPACE2(s,nextPL_nextwhite);
5485 #ifdef PERL_MAD
5486                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5487 #endif
5488
5489                     /* Two barewords in a row may indicate method call. */
5490
5491                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5492                         (tmp = intuit_method(s, gv, cv)))
5493                         return REPORT(tmp);
5494
5495                     /* If not a declared subroutine, it's an indirect object. */
5496                     /* (But it's an indir obj regardless for sort.) */
5497                     /* Also, if "_" follows a filetest operator, it's a bareword */
5498
5499                     if (
5500                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5501                          ((!gv || !cv) &&
5502                         (PL_last_lop_op != OP_MAPSTART &&
5503                          PL_last_lop_op != OP_GREPSTART))))
5504                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5505                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5506                        )
5507                     {
5508                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5509                         goto bareword;
5510                     }
5511                 }
5512
5513                 PL_expect = XOPERATOR;
5514 #ifdef PERL_MAD
5515                 if (isSPACE(*s))
5516                     s = SKIPSPACE2(s,nextPL_nextwhite);
5517                 PL_nextwhite = nextPL_nextwhite;
5518 #else
5519                 s = skipspace(s);
5520 #endif
5521
5522                 /* Is this a word before a => operator? */
5523                 if (*s == '=' && s[1] == '>' && !pkgname) {
5524                     CLINE;
5525                     sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5526                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5527                       SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5528                     TERM(WORD);
5529                 }
5530
5531                 /* If followed by a paren, it's certainly a subroutine. */
5532                 if (*s == '(') {
5533                     CLINE;
5534                     if (cv) {
5535                         d = s + 1;
5536                         while (SPACE_OR_TAB(*d))
5537                             d++;
5538                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5539                             s = d + 1;
5540                             goto its_constant;
5541                         }
5542                     }
5543 #ifdef PERL_MAD
5544                     if (PL_madskills) {
5545                         PL_nextwhite = PL_thiswhite;
5546                         PL_thiswhite = 0;
5547                     }
5548                     start_force(PL_curforce);
5549 #endif
5550                     NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5551                     PL_expect = XOPERATOR;
5552 #ifdef PERL_MAD
5553                     if (PL_madskills) {
5554                         PL_nextwhite = nextPL_nextwhite;
5555                         curmad('X', PL_thistoken);
5556                         PL_thistoken = newSVpvs("");
5557                     }
5558 #endif
5559                     force_next(WORD);
5560                     pl_yylval.ival = 0;
5561                     TOKEN('&');
5562                 }
5563
5564                 /* If followed by var or block, call it a method (unless sub) */
5565
5566                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5567                     PL_last_lop = PL_oldbufptr;
5568                     PL_last_lop_op = OP_METHOD;
5569                     PREBLOCK(METHOD);
5570                 }
5571
5572                 /* If followed by a bareword, see if it looks like indir obj. */
5573
5574                 if (!orig_keyword
5575                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5576                         && (tmp = intuit_method(s, gv, cv)))
5577                     return REPORT(tmp);
5578
5579                 /* Not a method, so call it a subroutine (if defined) */
5580
5581                 if (cv) {
5582                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5583                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5584                                 "Ambiguous use of -%s resolved as -&%s()",
5585                                 PL_tokenbuf, PL_tokenbuf);
5586                     /* Check for a constant sub */
5587                     if ((sv = gv_const_sv(gv))) {
5588                   its_constant:
5589                         SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5590                         ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5591                         pl_yylval.opval->op_private = 0;
5592                         TOKEN(WORD);
5593                     }
5594
5595                     /* Resolve to GV now. */
5596                     if (SvTYPE(gv) != SVt_PVGV) {
5597                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5598                         assert (SvTYPE(gv) == SVt_PVGV);
5599                         /* cv must have been some sort of placeholder, so
5600                            now needs replacing with a real code reference.  */
5601                         cv = GvCV(gv);
5602                     }
5603
5604                     op_free(pl_yylval.opval);
5605                     pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5606                     pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5607                     PL_last_lop = PL_oldbufptr;
5608                     PL_last_lop_op = OP_ENTERSUB;
5609                     /* Is there a prototype? */
5610                     if (
5611 #ifdef PERL_MAD
5612                         cv &&
5613 #endif
5614                         SvPOK(cv))
5615                     {
5616                         STRLEN protolen;
5617                         const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5618                         if (!protolen)
5619                             TERM(FUNC0SUB);
5620                         if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5621                             OPERATOR(UNIOPSUB);
5622                         while (*proto == ';')
5623                             proto++;
5624                         if (*proto == '&' && *s == '{') {
5625                             if (PL_curstash)
5626                                 sv_setpvs(PL_subname, "__ANON__");
5627                             else
5628                                 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5629                             PREBLOCK(LSTOPSUB);
5630                         }
5631                     }
5632 #ifdef PERL_MAD
5633                     {
5634                         if (PL_madskills) {
5635                             PL_nextwhite = PL_thiswhite;
5636                             PL_thiswhite = 0;
5637                         }
5638                         start_force(PL_curforce);
5639                         NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5640                         PL_expect = XTERM;
5641                         if (PL_madskills) {
5642                             PL_nextwhite = nextPL_nextwhite;
5643                             curmad('X', PL_thistoken);
5644                             PL_thistoken = newSVpvs("");
5645                         }
5646                         force_next(WORD);
5647                         TOKEN(NOAMP);
5648                     }
5649                 }
5650
5651                 /* Guess harder when madskills require "best effort". */
5652                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5653                     int probable_sub = 0;
5654                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5655                         probable_sub = 1;
5656                     else if (isALPHA(*s)) {
5657                         char tmpbuf[1024];
5658                         STRLEN tmplen;
5659                         d = s;
5660                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5661                         if (!keyword(tmpbuf, tmplen, 0))
5662                             probable_sub = 1;
5663                         else {
5664                             while (d < PL_bufend && isSPACE(*d))
5665                                 d++;
5666                             if (*d == '=' && d[1] == '>')
5667                                 probable_sub = 1;
5668                         }
5669                     }
5670                     if (probable_sub) {
5671                         gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5672                         op_free(pl_yylval.opval);
5673                         pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5674                         pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5675                         PL_last_lop = PL_oldbufptr;
5676                         PL_last_lop_op = OP_ENTERSUB;
5677                         PL_nextwhite = PL_thiswhite;
5678                         PL_thiswhite = 0;
5679                         start_force(PL_curforce);
5680                         NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5681                         PL_expect = XTERM;
5682                         PL_nextwhite = nextPL_nextwhite;
5683                         curmad('X', PL_thistoken);
5684                         PL_thistoken = newSVpvs("");
5685                         force_next(WORD);
5686                         TOKEN(NOAMP);
5687                     }
5688 #else
5689                     NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5690                     PL_expect = XTERM;
5691                     force_next(WORD);
5692                     TOKEN(NOAMP);
5693 #endif
5694                 }
5695
5696                 /* Call it a bare word */
5697
5698                 bareword:
5699                 if (PL_hints & HINT_STRICT_SUBS)
5700                     pl_yylval.opval->op_private |= OPpCONST_STRICT;
5701                 else {
5702                     if (lastchar != '-') {
5703                         if (ckWARN(WARN_RESERVED)) {
5704                             d = PL_tokenbuf;
5705                             while (isLOWER(*d))
5706                                 d++;
5707                             if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5708                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5709                                        PL_tokenbuf);
5710                         }
5711                     }
5712                 }
5713
5714             safe_bareword:
5715                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5716                     && ckWARN_d(WARN_AMBIGUOUS)) {
5717                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5718                         "Operator or semicolon missing before %c%s",
5719                         lastchar, PL_tokenbuf);
5720                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5721                         "Ambiguous use of %c resolved as operator %c",
5722                         lastchar, lastchar);
5723                 }
5724                 TOKEN(WORD);
5725             }
5726
5727         case KEY___FILE__:
5728             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5729                                         newSVpv(CopFILE(PL_curcop),0));
5730             TERM(THING);
5731
5732         case KEY___LINE__:
5733             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5734                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5735             TERM(THING);
5736
5737         case KEY___PACKAGE__:
5738             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5739                                         (PL_curstash
5740                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5741                                          : &PL_sv_undef));
5742             TERM(THING);
5743
5744         case KEY___DATA__:
5745         case KEY___END__: {
5746             GV *gv;
5747             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5748                 const char *pname = "main";
5749                 if (PL_tokenbuf[2] == 'D')
5750                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5751                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5752                                 SVt_PVIO);
5753                 GvMULTI_on(gv);
5754                 if (!GvIO(gv))
5755                     GvIOp(gv) = newIO();
5756                 IoIFP(GvIOp(gv)) = PL_rsfp;
5757 #if defined(HAS_FCNTL) && defined(F_SETFD)
5758                 {
5759                     const int fd = PerlIO_fileno(PL_rsfp);
5760                     fcntl(fd,F_SETFD,fd >= 3);
5761                 }
5762 #endif
5763                 /* Mark this internal pseudo-handle as clean */
5764                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5765                 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5766                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5767                 else
5768                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5769 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5770                 /* if the script was opened in binmode, we need to revert
5771                  * it to text mode for compatibility; but only iff it has CRs
5772                  * XXX this is a questionable hack at best. */
5773                 if (PL_bufend-PL_bufptr > 2
5774                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5775                 {
5776                     Off_t loc = 0;
5777                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5778                         loc = PerlIO_tell(PL_rsfp);
5779                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5780                     }
5781 #ifdef NETWARE
5782                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5783 #else
5784                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5785 #endif  /* NETWARE */
5786 #ifdef PERLIO_IS_STDIO /* really? */
5787 #  if defined(__BORLANDC__)
5788                         /* XXX see note in do_binmode() */
5789                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5790 #  endif
5791 #endif
5792                         if (loc > 0)
5793                             PerlIO_seek(PL_rsfp, loc, 0);
5794                     }
5795                 }
5796 #endif
5797 #ifdef PERLIO_LAYERS
5798                 if (!IN_BYTES) {
5799                     if (UTF)
5800                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5801                     else if (PL_encoding) {
5802                         SV *name;
5803                         dSP;
5804                         ENTER;
5805                         SAVETMPS;
5806                         PUSHMARK(sp);
5807                         EXTEND(SP, 1);
5808                         XPUSHs(PL_encoding);
5809                         PUTBACK;
5810                         call_method("name", G_SCALAR);
5811                         SPAGAIN;
5812                         name = POPs;
5813                         PUTBACK;
5814                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5815                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5816                                                       SVfARG(name)));
5817                         FREETMPS;
5818                         LEAVE;
5819                     }
5820                 }
5821 #endif
5822 #ifdef PERL_MAD
5823                 if (PL_madskills) {
5824                     if (PL_realtokenstart >= 0) {
5825                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5826                         if (!PL_endwhite)
5827                             PL_endwhite = newSVpvs("");
5828                         sv_catsv(PL_endwhite, PL_thiswhite);
5829                         PL_thiswhite = 0;
5830                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5831                         PL_realtokenstart = -1;
5832                     }
5833                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5834                                  SvCUR(PL_endwhite))) != NULL) ;
5835                 }
5836 #endif
5837                 PL_rsfp = NULL;
5838             }
5839             goto fake_eof;
5840         }
5841
5842         case KEY_AUTOLOAD:
5843         case KEY_DESTROY:
5844         case KEY_BEGIN:
5845         case KEY_UNITCHECK:
5846         case KEY_CHECK:
5847         case KEY_INIT:
5848         case KEY_END:
5849             if (PL_expect == XSTATE) {
5850                 s = PL_bufptr;
5851                 goto really_sub;
5852             }
5853             goto just_a_word;
5854
5855         case KEY_CORE:
5856             if (*s == ':' && s[1] == ':') {
5857                 s += 2;
5858                 d = s;
5859                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5860                 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5861                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5862                 if (tmp < 0)
5863                     tmp = -tmp;
5864                 else if (tmp == KEY_require || tmp == KEY_do)
5865                     /* that's a way to remember we saw "CORE::" */
5866                     orig_keyword = tmp;
5867                 goto reserved_word;
5868             }
5869             goto just_a_word;
5870
5871         case KEY_abs:
5872             UNI(OP_ABS);
5873
5874         case KEY_alarm:
5875             UNI(OP_ALARM);
5876
5877         case KEY_accept:
5878             LOP(OP_ACCEPT,XTERM);
5879
5880         case KEY_and:
5881             OPERATOR(ANDOP);
5882
5883         case KEY_atan2:
5884             LOP(OP_ATAN2,XTERM);
5885
5886         case KEY_bind:
5887             LOP(OP_BIND,XTERM);
5888
5889         case KEY_binmode:
5890             LOP(OP_BINMODE,XTERM);
5891
5892         case KEY_bless:
5893             LOP(OP_BLESS,XTERM);
5894
5895         case KEY_break:
5896             FUN0(OP_BREAK);
5897
5898         case KEY_chop:
5899             UNI(OP_CHOP);
5900
5901         case KEY_continue:
5902             /* When 'use switch' is in effect, continue has a dual
5903                life as a control operator. */
5904             {
5905                 if (!FEATURE_IS_ENABLED("switch"))
5906                     PREBLOCK(CONTINUE);
5907                 else {
5908                     /* We have to disambiguate the two senses of
5909                       "continue". If the next token is a '{' then
5910                       treat it as the start of a continue block;
5911                       otherwise treat it as a control operator.
5912                      */
5913                     s = skipspace(s);
5914                     if (*s == '{')
5915             PREBLOCK(CONTINUE);
5916                     else
5917                         FUN0(OP_CONTINUE);
5918                 }
5919             }
5920
5921         case KEY_chdir:
5922             /* may use HOME */
5923             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5924             UNI(OP_CHDIR);
5925
5926         case KEY_close:
5927             UNI(OP_CLOSE);
5928
5929         case KEY_closedir:
5930             UNI(OP_CLOSEDIR);
5931
5932         case KEY_cmp:
5933             Eop(OP_SCMP);
5934
5935         case KEY_caller:
5936             UNI(OP_CALLER);
5937
5938         case KEY_crypt:
5939 #ifdef FCRYPT
5940             if (!PL_cryptseen) {
5941                 PL_cryptseen = TRUE;
5942                 init_des();
5943             }
5944 #endif
5945             LOP(OP_CRYPT,XTERM);
5946
5947         case KEY_chmod:
5948             LOP(OP_CHMOD,XTERM);
5949
5950         case KEY_chown:
5951             LOP(OP_CHOWN,XTERM);
5952
5953         case KEY_connect:
5954             LOP(OP_CONNECT,XTERM);
5955
5956         case KEY_chr:
5957             UNI(OP_CHR);
5958
5959         case KEY_cos:
5960             UNI(OP_COS);
5961
5962         case KEY_chroot:
5963             UNI(OP_CHROOT);
5964
5965         case KEY_default:
5966             PREBLOCK(DEFAULT);
5967
5968         case KEY_do:
5969             s = SKIPSPACE1(s);
5970             if (*s == '{')
5971                 PRETERMBLOCK(DO);
5972             if (*s != '\'')
5973                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5974             if (orig_keyword == KEY_do) {
5975                 orig_keyword = 0;
5976                 pl_yylval.ival = 1;
5977             }
5978             else
5979                 pl_yylval.ival = 0;
5980             OPERATOR(DO);
5981
5982         case KEY_die:
5983             PL_hints |= HINT_BLOCK_SCOPE;
5984             LOP(OP_DIE,XTERM);
5985
5986         case KEY_defined:
5987             UNI(OP_DEFINED);
5988
5989         case KEY_delete:
5990             UNI(OP_DELETE);
5991
5992         case KEY_dbmopen:
5993             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5994             LOP(OP_DBMOPEN,XTERM);
5995
5996         case KEY_dbmclose:
5997             UNI(OP_DBMCLOSE);
5998
5999         case KEY_dump:
6000             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6001             LOOPX(OP_DUMP);
6002
6003         case KEY_else:
6004             PREBLOCK(ELSE);
6005
6006         case KEY_elsif:
6007             pl_yylval.ival = CopLINE(PL_curcop);
6008             OPERATOR(ELSIF);
6009
6010         case KEY_eq:
6011             Eop(OP_SEQ);
6012
6013         case KEY_exists:
6014             UNI(OP_EXISTS);
6015
6016         case KEY_exit:
6017             if (PL_madskills)
6018                 UNI(OP_INT);
6019             UNI(OP_EXIT);
6020
6021         case KEY_eval:
6022             s = SKIPSPACE1(s);
6023             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6024             UNIBRACK(OP_ENTEREVAL);
6025
6026         case KEY_eof:
6027             UNI(OP_EOF);
6028
6029         case KEY_exp:
6030             UNI(OP_EXP);
6031
6032         case KEY_each:
6033             UNI(OP_EACH);
6034
6035         case KEY_exec:
6036             LOP(OP_EXEC,XREF);
6037
6038         case KEY_endhostent:
6039             FUN0(OP_EHOSTENT);
6040
6041         case KEY_endnetent:
6042             FUN0(OP_ENETENT);
6043
6044         case KEY_endservent:
6045             FUN0(OP_ESERVENT);
6046
6047         case KEY_endprotoent:
6048             FUN0(OP_EPROTOENT);
6049
6050         case KEY_endpwent:
6051             FUN0(OP_EPWENT);
6052
6053         case KEY_endgrent:
6054             FUN0(OP_EGRENT);
6055
6056         case KEY_for:
6057         case KEY_foreach:
6058             pl_yylval.ival = CopLINE(PL_curcop);
6059             s = SKIPSPACE1(s);
6060             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6061                 char *p = s;
6062 #ifdef PERL_MAD
6063                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6064 #endif
6065
6066                 if ((PL_bufend - p) >= 3 &&
6067                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6068                     p += 2;
6069                 else if ((PL_bufend - p) >= 4 &&
6070                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6071                     p += 3;
6072                 p = PEEKSPACE(p);
6073                 if (isIDFIRST_lazy_if(p,UTF)) {
6074                     p = scan_ident(p, PL_bufend,
6075                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6076                     p = PEEKSPACE(p);
6077                 }
6078                 if (*p != '$')
6079                     Perl_croak(aTHX_ "Missing $ on loop variable");
6080 #ifdef PERL_MAD
6081                 s = SvPVX(PL_linestr) + soff;
6082 #endif
6083             }
6084             OPERATOR(FOR);
6085
6086         case KEY_formline:
6087             LOP(OP_FORMLINE,XTERM);
6088
6089         case KEY_fork:
6090             FUN0(OP_FORK);
6091
6092         case KEY_fcntl:
6093             LOP(OP_FCNTL,XTERM);
6094
6095         case KEY_fileno:
6096             UNI(OP_FILENO);
6097
6098         case KEY_flock:
6099             LOP(OP_FLOCK,XTERM);
6100
6101         case KEY_gt:
6102             Rop(OP_SGT);
6103
6104         case KEY_ge:
6105             Rop(OP_SGE);
6106
6107         case KEY_grep:
6108             LOP(OP_GREPSTART, XREF);
6109
6110         case KEY_goto:
6111             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6112             LOOPX(OP_GOTO);
6113
6114         case KEY_gmtime:
6115             UNI(OP_GMTIME);
6116
6117         case KEY_getc:
6118             UNIDOR(OP_GETC);
6119
6120         case KEY_getppid:
6121             FUN0(OP_GETPPID);
6122
6123         case KEY_getpgrp:
6124             UNI(OP_GETPGRP);
6125
6126         case KEY_getpriority:
6127             LOP(OP_GETPRIORITY,XTERM);
6128
6129         case KEY_getprotobyname:
6130             UNI(OP_GPBYNAME);
6131
6132         case KEY_getprotobynumber:
6133             LOP(OP_GPBYNUMBER,XTERM);
6134
6135         case KEY_getprotoent:
6136             FUN0(OP_GPROTOENT);
6137
6138         case KEY_getpwent:
6139             FUN0(OP_GPWENT);
6140
6141         case KEY_getpwnam:
6142             UNI(OP_GPWNAM);
6143
6144         case KEY_getpwuid:
6145             UNI(OP_GPWUID);
6146
6147         case KEY_getpeername:
6148             UNI(OP_GETPEERNAME);
6149
6150         case KEY_gethostbyname:
6151             UNI(OP_GHBYNAME);
6152
6153         case KEY_gethostbyaddr:
6154             LOP(OP_GHBYADDR,XTERM);
6155
6156         case KEY_gethostent:
6157             FUN0(OP_GHOSTENT);
6158
6159         case KEY_getnetbyname:
6160             UNI(OP_GNBYNAME);
6161
6162         case KEY_getnetbyaddr:
6163             LOP(OP_GNBYADDR,XTERM);
6164
6165         case KEY_getnetent:
6166             FUN0(OP_GNETENT);
6167
6168         case KEY_getservbyname:
6169             LOP(OP_GSBYNAME,XTERM);
6170
6171         case KEY_getservbyport:
6172             LOP(OP_GSBYPORT,XTERM);
6173
6174         case KEY_getservent:
6175             FUN0(OP_GSERVENT);
6176
6177         case KEY_getsockname:
6178             UNI(OP_GETSOCKNAME);
6179
6180         case KEY_getsockopt:
6181             LOP(OP_GSOCKOPT,XTERM);
6182
6183         case KEY_getgrent:
6184             FUN0(OP_GGRENT);
6185
6186         case KEY_getgrnam:
6187             UNI(OP_GGRNAM);
6188
6189         case KEY_getgrgid:
6190             UNI(OP_GGRGID);
6191
6192         case KEY_getlogin:
6193             FUN0(OP_GETLOGIN);
6194
6195         case KEY_given:
6196             pl_yylval.ival = CopLINE(PL_curcop);
6197             OPERATOR(GIVEN);
6198
6199         case KEY_glob:
6200             LOP(OP_GLOB,XTERM);
6201
6202         case KEY_hex:
6203             UNI(OP_HEX);
6204
6205         case KEY_if:
6206             pl_yylval.ival = CopLINE(PL_curcop);
6207             OPERATOR(IF);
6208
6209         case KEY_index:
6210             LOP(OP_INDEX,XTERM);
6211
6212         case KEY_int:
6213             UNI(OP_INT);
6214
6215         case KEY_ioctl:
6216             LOP(OP_IOCTL,XTERM);
6217
6218         case KEY_join:
6219             LOP(OP_JOIN,XTERM);
6220
6221         case KEY_keys:
6222             UNI(OP_KEYS);
6223
6224         case KEY_kill:
6225             LOP(OP_KILL,XTERM);
6226
6227         case KEY_last:
6228             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6229             LOOPX(OP_LAST);
6230
6231         case KEY_lc:
6232             UNI(OP_LC);
6233
6234         case KEY_lcfirst:
6235             UNI(OP_LCFIRST);
6236
6237         case KEY_local:
6238             pl_yylval.ival = 0;
6239             OPERATOR(LOCAL);
6240
6241         case KEY_length:
6242             UNI(OP_LENGTH);
6243
6244         case KEY_lt:
6245             Rop(OP_SLT);
6246
6247         case KEY_le:
6248             Rop(OP_SLE);
6249
6250         case KEY_localtime:
6251             UNI(OP_LOCALTIME);
6252
6253         case KEY_log:
6254             UNI(OP_LOG);
6255
6256         case KEY_link:
6257             LOP(OP_LINK,XTERM);
6258
6259         case KEY_listen:
6260             LOP(OP_LISTEN,XTERM);
6261
6262         case KEY_lock:
6263             UNI(OP_LOCK);
6264
6265         case KEY_lstat:
6266             UNI(OP_LSTAT);
6267
6268         case KEY_m:
6269             s = scan_pat(s,OP_MATCH);
6270             TERM(sublex_start());
6271
6272         case KEY_map:
6273             LOP(OP_MAPSTART, XREF);
6274
6275         case KEY_mkdir:
6276             LOP(OP_MKDIR,XTERM);
6277
6278         case KEY_msgctl:
6279             LOP(OP_MSGCTL,XTERM);
6280
6281         case KEY_msgget:
6282             LOP(OP_MSGGET,XTERM);
6283
6284         case KEY_msgrcv:
6285             LOP(OP_MSGRCV,XTERM);
6286
6287         case KEY_msgsnd:
6288             LOP(OP_MSGSND,XTERM);
6289
6290         case KEY_our:
6291         case KEY_my:
6292         case KEY_state:
6293             PL_in_my = (U16)tmp;
6294             s = SKIPSPACE1(s);
6295             if (isIDFIRST_lazy_if(s,UTF)) {
6296 #ifdef PERL_MAD
6297                 char* start = s;
6298 #endif
6299                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6300                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6301                     goto really_sub;
6302                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6303                 if (!PL_in_my_stash) {
6304                     char tmpbuf[1024];
6305                     PL_bufptr = s;
6306                     my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6307                     yyerror(tmpbuf);
6308                 }
6309 #ifdef PERL_MAD
6310                 if (PL_madskills) {     /* just add type to declarator token */
6311                     sv_catsv(PL_thistoken, PL_nextwhite);
6312                     PL_nextwhite = 0;
6313                     sv_catpvn(PL_thistoken, start, s - start);
6314                 }
6315 #endif
6316             }
6317             pl_yylval.ival = 1;
6318             OPERATOR(MY);
6319
6320         case KEY_next:
6321             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6322             LOOPX(OP_NEXT);
6323
6324         case KEY_ne:
6325             Eop(OP_SNE);
6326
6327         case KEY_no:
6328             s = tokenize_use(0, s);
6329             OPERATOR(USE);
6330
6331         case KEY_not:
6332             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6333                 FUN1(OP_NOT);
6334             else
6335                 OPERATOR(NOTOP);
6336
6337         case KEY_open:
6338             s = SKIPSPACE1(s);
6339             if (isIDFIRST_lazy_if(s,UTF)) {
6340                 const char *t;
6341                 for (d = s; isALNUM_lazy_if(d,UTF);)
6342                     d++;
6343                 for (t=d; isSPACE(*t);)
6344                     t++;
6345                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6346                     /* [perl #16184] */
6347                     && !(t[0] == '=' && t[1] == '>')
6348                 ) {
6349                     int parms_len = (int)(d-s);
6350                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6351                            "Precedence problem: open %.*s should be open(%.*s)",
6352                             parms_len, s, parms_len, s);
6353                 }
6354             }
6355             LOP(OP_OPEN,XTERM);
6356
6357         case KEY_or:
6358             pl_yylval.ival = OP_OR;
6359             OPERATOR(OROP);
6360
6361         case KEY_ord:
6362             UNI(OP_ORD);
6363
6364         case KEY_oct:
6365             UNI(OP_OCT);
6366
6367         case KEY_opendir:
6368             LOP(OP_OPEN_DIR,XTERM);
6369
6370         case KEY_print:
6371             checkcomma(s,PL_tokenbuf,"filehandle");
6372             LOP(OP_PRINT,XREF);
6373
6374         case KEY_printf:
6375             checkcomma(s,PL_tokenbuf,"filehandle");
6376             LOP(OP_PRTF,XREF);
6377
6378         case KEY_prototype:
6379             UNI(OP_PROTOTYPE);
6380
6381         case KEY_push:
6382             LOP(OP_PUSH,XTERM);
6383
6384         case KEY_pop:
6385             UNIDOR(OP_POP);
6386
6387         case KEY_pos:
6388             UNIDOR(OP_POS);
6389
6390         case KEY_pack:
6391             LOP(OP_PACK,XTERM);
6392
6393         case KEY_package:
6394             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6395             OPERATOR(PACKAGE);
6396
6397         case KEY_pipe:
6398             LOP(OP_PIPE_OP,XTERM);
6399
6400         case KEY_q:
6401             s = scan_str(s,!!PL_madskills,FALSE);
6402             if (!s)
6403                 missingterm(NULL);
6404             pl_yylval.ival = OP_CONST;
6405             TERM(sublex_start());
6406
6407         case KEY_quotemeta:
6408             UNI(OP_QUOTEMETA);
6409
6410         case KEY_qw:
6411             s = scan_str(s,!!PL_madskills,FALSE);
6412             if (!s)
6413                 missingterm(NULL);
6414             PL_expect = XOPERATOR;
6415             force_next(')');
6416             if (SvCUR(PL_lex_stuff)) {
6417                 OP *words = NULL;
6418                 int warned = 0;
6419                 d = SvPV_force(PL_lex_stuff, len);
6420                 while (len) {
6421                     for (; isSPACE(*d) && len; --len, ++d)
6422                         /**/;
6423                     if (len) {
6424                         SV *sv;
6425                         const char *b = d;
6426                         if (!warned && ckWARN(WARN_QW)) {
6427                             for (; !isSPACE(*d) && len; --len, ++d) {
6428                                 if (*d == ',') {
6429                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6430                                         "Possible attempt to separate words with commas");
6431                                     ++warned;
6432                                 }
6433                                 else if (*d == '#') {
6434                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6435                                         "Possible attempt to put comments in qw() list");
6436                                     ++warned;
6437                                 }
6438                             }
6439                         }
6440                         else {
6441                             for (; !isSPACE(*d) && len; --len, ++d)
6442                                 /**/;
6443                         }
6444                         sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6445                         words = append_elem(OP_LIST, words,
6446                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6447                     }
6448                 }
6449                 if (words) {
6450                     start_force(PL_curforce);
6451                     NEXTVAL_NEXTTOKE.opval = words;
6452                     force_next(THING);
6453                 }
6454             }
6455             if (PL_lex_stuff) {
6456                 SvREFCNT_dec(PL_lex_stuff);
6457                 PL_lex_stuff = NULL;
6458             }
6459             PL_expect = XTERM;
6460             TOKEN('(');
6461
6462         case KEY_qq:
6463             s = scan_str(s,!!PL_madskills,FALSE);
6464             if (!s)
6465                 missingterm(NULL);
6466             pl_yylval.ival = OP_STRINGIFY;
6467             if (SvIVX(PL_lex_stuff) == '\'')
6468                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6469             TERM(sublex_start());
6470
6471         case KEY_qr:
6472             s = scan_pat(s,OP_QR);
6473             TERM(sublex_start());
6474
6475         case KEY_qx:
6476             s = scan_str(s,!!PL_madskills,FALSE);
6477             if (!s)
6478                 missingterm(NULL);
6479             readpipe_override();
6480             TERM(sublex_start());
6481
6482         case KEY_return:
6483             OLDLOP(OP_RETURN);
6484
6485         case KEY_require:
6486             s = SKIPSPACE1(s);
6487             if (isDIGIT(*s)) {
6488                 s = force_version(s, FALSE);
6489             }
6490             else if (*s != 'v' || !isDIGIT(s[1])
6491                     || (s = force_version(s, TRUE), *s == 'v'))
6492             {
6493                 *PL_tokenbuf = '\0';
6494                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6495                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6496                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6497                 else if (*s == '<')
6498                     yyerror("<> should be quotes");
6499             }
6500             if (orig_keyword == KEY_require) {
6501                 orig_keyword = 0;
6502                 pl_yylval.ival = 1;
6503             }
6504             else
6505                 pl_yylval.ival = 0;
6506             PL_expect = XTERM;
6507             PL_bufptr = s;
6508             PL_last_uni = PL_oldbufptr;
6509             PL_last_lop_op = OP_REQUIRE;
6510             s = skipspace(s);
6511             return REPORT( (int)REQUIRE );
6512
6513         case KEY_reset:
6514             UNI(OP_RESET);
6515
6516         case KEY_redo:
6517             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6518             LOOPX(OP_REDO);
6519
6520         case KEY_rename:
6521             LOP(OP_RENAME,XTERM);
6522
6523         case KEY_rand:
6524             UNI(OP_RAND);
6525
6526         case KEY_rmdir:
6527             UNI(OP_RMDIR);
6528
6529         case KEY_rindex:
6530             LOP(OP_RINDEX,XTERM);
6531
6532         case KEY_read:
6533             LOP(OP_READ,XTERM);
6534
6535         case KEY_readdir:
6536             UNI(OP_READDIR);
6537
6538         case KEY_readline:
6539             UNIDOR(OP_READLINE);
6540
6541         case KEY_readpipe:
6542             UNIDOR(OP_BACKTICK);
6543
6544         case KEY_rewinddir:
6545             UNI(OP_REWINDDIR);
6546
6547         case KEY_recv:
6548             LOP(OP_RECV,XTERM);
6549
6550         case KEY_reverse:
6551             LOP(OP_REVERSE,XTERM);
6552
6553         case KEY_readlink:
6554             UNIDOR(OP_READLINK);
6555
6556         case KEY_ref:
6557             UNI(OP_REF);
6558
6559         case KEY_s:
6560             s = scan_subst(s);
6561             if (pl_yylval.opval)
6562                 TERM(sublex_start());
6563             else
6564                 TOKEN(1);       /* force error */
6565
6566         case KEY_say:
6567             checkcomma(s,PL_tokenbuf,"filehandle");
6568             LOP(OP_SAY,XREF);
6569
6570         case KEY_chomp:
6571             UNI(OP_CHOMP);
6572
6573         case KEY_scalar:
6574             UNI(OP_SCALAR);
6575
6576         case KEY_select:
6577             LOP(OP_SELECT,XTERM);
6578
6579         case KEY_seek:
6580             LOP(OP_SEEK,XTERM);
6581
6582         case KEY_semctl:
6583             LOP(OP_SEMCTL,XTERM);
6584
6585         case KEY_semget:
6586             LOP(OP_SEMGET,XTERM);
6587
6588         case KEY_semop:
6589             LOP(OP_SEMOP,XTERM);
6590
6591         case KEY_send:
6592             LOP(OP_SEND,XTERM);
6593
6594         case KEY_setpgrp:
6595             LOP(OP_SETPGRP,XTERM);
6596
6597         case KEY_setpriority:
6598             LOP(OP_SETPRIORITY,XTERM);
6599
6600         case KEY_sethostent:
6601             UNI(OP_SHOSTENT);
6602
6603         case KEY_setnetent:
6604             UNI(OP_SNETENT);
6605
6606         case KEY_setservent:
6607             UNI(OP_SSERVENT);
6608
6609         case KEY_setprotoent:
6610             UNI(OP_SPROTOENT);
6611
6612         case KEY_setpwent:
6613             FUN0(OP_SPWENT);
6614
6615         case KEY_setgrent:
6616             FUN0(OP_SGRENT);
6617
6618         case KEY_seekdir:
6619             LOP(OP_SEEKDIR,XTERM);
6620
6621         case KEY_setsockopt:
6622             LOP(OP_SSOCKOPT,XTERM);
6623
6624         case KEY_shift:
6625             UNIDOR(OP_SHIFT);
6626
6627         case KEY_shmctl:
6628             LOP(OP_SHMCTL,XTERM);
6629
6630         case KEY_shmget:
6631             LOP(OP_SHMGET,XTERM);
6632
6633         case KEY_shmread:
6634             LOP(OP_SHMREAD,XTERM);
6635
6636         case KEY_shmwrite:
6637             LOP(OP_SHMWRITE,XTERM);
6638
6639         case KEY_shutdown:
6640             LOP(OP_SHUTDOWN,XTERM);
6641
6642         case KEY_sin:
6643             UNI(OP_SIN);
6644
6645         case KEY_sleep:
6646             UNI(OP_SLEEP);
6647
6648         case KEY_socket:
6649             LOP(OP_SOCKET,XTERM);
6650
6651         case KEY_socketpair:
6652             LOP(OP_SOCKPAIR,XTERM);
6653
6654         case KEY_sort:
6655             checkcomma(s,PL_tokenbuf,"subroutine name");
6656             s = SKIPSPACE1(s);
6657             if (*s == ';' || *s == ')')         /* probably a close */
6658                 Perl_croak(aTHX_ "sort is now a reserved word");
6659             PL_expect = XTERM;
6660             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6661             LOP(OP_SORT,XREF);
6662
6663         case KEY_split:
6664             LOP(OP_SPLIT,XTERM);
6665
6666         case KEY_sprintf:
6667             LOP(OP_SPRINTF,XTERM);
6668
6669         case KEY_splice:
6670             LOP(OP_SPLICE,XTERM);
6671
6672         case KEY_sqrt:
6673             UNI(OP_SQRT);
6674
6675         case KEY_srand:
6676             UNI(OP_SRAND);
6677
6678         case KEY_stat:
6679             UNI(OP_STAT);
6680
6681         case KEY_study:
6682             UNI(OP_STUDY);
6683
6684         case KEY_substr:
6685             LOP(OP_SUBSTR,XTERM);
6686
6687         case KEY_format:
6688         case KEY_sub:
6689           really_sub:
6690             {
6691                 char tmpbuf[sizeof PL_tokenbuf];
6692                 SSize_t tboffset = 0;
6693                 expectation attrful;
6694                 bool have_name, have_proto;
6695                 const int key = tmp;
6696
6697 #ifdef PERL_MAD
6698                 SV *tmpwhite = 0;
6699
6700                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6701                 SV *subtoken = newSVpvn(tstart, s - tstart);
6702                 PL_thistoken = 0;
6703
6704                 d = s;
6705                 s = SKIPSPACE2(s,tmpwhite);
6706 #else
6707                 s = skipspace(s);
6708 #endif
6709
6710                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6711                     (*s == ':' && s[1] == ':'))
6712                 {
6713 #ifdef PERL_MAD
6714                     SV *nametoke = NULL;
6715 #endif
6716
6717                     PL_expect = XBLOCK;
6718                     attrful = XATTRBLOCK;
6719                     /* remember buffer pos'n for later force_word */
6720                     tboffset = s - PL_oldbufptr;
6721                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6722 #ifdef PERL_MAD
6723                     if (PL_madskills)
6724                         nametoke = newSVpvn(s, d - s);
6725 #endif
6726                     if (memchr(tmpbuf, ':', len))
6727                         sv_setpvn(PL_subname, tmpbuf, len);
6728                     else {
6729                         sv_setsv(PL_subname,PL_curstname);
6730                         sv_catpvs(PL_subname,"::");
6731                         sv_catpvn(PL_subname,tmpbuf,len);
6732                     }
6733                     have_name = TRUE;
6734
6735 #ifdef PERL_MAD
6736
6737                     start_force(0);
6738                     CURMAD('X', nametoke);
6739                     CURMAD('_', tmpwhite);
6740                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6741                                       FALSE, TRUE, TRUE);
6742
6743                     s = SKIPSPACE2(d,tmpwhite);
6744 #else
6745                     s = skipspace(d);
6746 #endif
6747                 }
6748                 else {
6749                     if (key == KEY_my)
6750                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6751                     PL_expect = XTERMBLOCK;
6752                     attrful = XATTRTERM;
6753                     sv_setpvs(PL_subname,"?");
6754                     have_name = FALSE;
6755                 }
6756
6757                 if (key == KEY_format) {
6758                     if (*s == '=')
6759                         PL_lex_formbrack = PL_lex_brackets + 1;
6760 #ifdef PERL_MAD
6761                     PL_thistoken = subtoken;
6762                     s = d;
6763 #else
6764                     if (have_name)
6765                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6766                                           FALSE, TRUE, TRUE);
6767 #endif
6768                     OPERATOR(FORMAT);
6769                 }
6770
6771                 /* Look for a prototype */
6772                 if (*s == '(') {
6773                     char *p;
6774                     bool bad_proto = FALSE;
6775                     bool in_brackets = FALSE;
6776                     char greedy_proto = ' ';
6777                     bool proto_after_greedy_proto = FALSE;
6778                     bool must_be_last = FALSE;
6779                     bool underscore = FALSE;
6780                     bool seen_underscore = FALSE;
6781                     const bool warnsyntax = ckWARN(WARN_SYNTAX);
6782
6783                     s = scan_str(s,!!PL_madskills,FALSE);
6784                     if (!s)
6785                         Perl_croak(aTHX_ "Prototype not terminated");
6786                     /* strip spaces and check for bad characters */
6787                     d = SvPVX(PL_lex_stuff);
6788                     tmp = 0;
6789                     for (p = d; *p; ++p) {
6790                         if (!isSPACE(*p)) {
6791                             d[tmp++] = *p;
6792
6793                             if (warnsyntax) {
6794                                 if (must_be_last)
6795                                     proto_after_greedy_proto = TRUE;
6796                                 if (!strchr("$@%*;[]&\\_", *p)) {
6797                                     bad_proto = TRUE;
6798                                 }
6799                                 else {
6800                                     if ( underscore ) {
6801                                         if ( *p != ';' )
6802                                             bad_proto = TRUE;
6803                                         underscore = FALSE;
6804                                     }
6805                                     if ( *p == '[' ) {
6806                                         in_brackets = TRUE;
6807                                     }
6808                                     else if ( *p == ']' ) {
6809                                         in_brackets = FALSE;
6810                                     }
6811                                     else if ( (*p == '@' || *p == '%') &&
6812                                          ( tmp < 2 || d[tmp-2] != '\\' ) &&
6813                                          !in_brackets ) {
6814                                         must_be_last = TRUE;
6815                                         greedy_proto = *p;
6816                                     }
6817                                     else if ( *p == '_' ) {
6818                                         underscore = seen_underscore = TRUE;
6819                                     }
6820                                 }
6821                             }
6822                         }
6823                     }
6824                     d[tmp] = '\0';
6825                     if (proto_after_greedy_proto)
6826                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6827                                     "Prototype after '%c' for %"SVf" : %s",
6828                                     greedy_proto, SVfARG(PL_subname), d);
6829                     if (bad_proto)
6830                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6831                                     "Illegal character %sin prototype for %"SVf" : %s",
6832                                     seen_underscore ? "after '_' " : "",
6833                                     SVfARG(PL_subname), d);
6834                     SvCUR_set(PL_lex_stuff, tmp);
6835                     have_proto = TRUE;
6836
6837 #ifdef PERL_MAD
6838                     start_force(0);
6839                     CURMAD('q', PL_thisopen);
6840                     CURMAD('_', tmpwhite);
6841                     CURMAD('=', PL_thisstuff);
6842                     CURMAD('Q', PL_thisclose);
6843                     NEXTVAL_NEXTTOKE.opval =
6844                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6845                     PL_lex_stuff = NULL;
6846                     force_next(THING);
6847
6848                     s = SKIPSPACE2(s,tmpwhite);
6849 #else
6850                     s = skipspace(s);
6851 #endif
6852                 }
6853                 else
6854                     have_proto = FALSE;
6855
6856                 if (*s == ':' && s[1] != ':')
6857                     PL_expect = attrful;
6858                 else if (*s != '{' && key == KEY_sub) {
6859                     if (!have_name)
6860                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6861                     else if (*s != ';')
6862                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6863                 }
6864
6865 #ifdef PERL_MAD
6866                 start_force(0);
6867                 if (tmpwhite) {
6868                     if (PL_madskills)
6869                         curmad('^', newSVpvs(""));
6870                     CURMAD('_', tmpwhite);
6871                 }
6872                 force_next(0);
6873
6874                 PL_thistoken = subtoken;
6875 #else
6876                 if (have_proto) {
6877                     NEXTVAL_NEXTTOKE.opval =
6878                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6879                     PL_lex_stuff = NULL;
6880                     force_next(THING);
6881                 }
6882 #endif
6883                 if (!have_name) {
6884                     if (PL_curstash)
6885                         sv_setpvs(PL_subname, "__ANON__");
6886                     else
6887                         sv_setpvs(PL_subname, "__ANON__::__ANON__");
6888                     TOKEN(ANONSUB);
6889                 }
6890 #ifndef PERL_MAD
6891                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6892                                   FALSE, TRUE, TRUE);
6893 #endif
6894                 if (key == KEY_my)
6895                     TOKEN(MYSUB);
6896                 TOKEN(SUB);
6897             }
6898
6899         case KEY_system:
6900             LOP(OP_SYSTEM,XREF);
6901
6902         case KEY_symlink:
6903             LOP(OP_SYMLINK,XTERM);
6904
6905         case KEY_syscall:
6906             LOP(OP_SYSCALL,XTERM);
6907
6908         case KEY_sysopen:
6909             LOP(OP_SYSOPEN,XTERM);
6910
6911         case KEY_sysseek:
6912             LOP(OP_SYSSEEK,XTERM);
6913
6914         case KEY_sysread:
6915             LOP(OP_SYSREAD,XTERM);
6916
6917         case KEY_syswrite:
6918             LOP(OP_SYSWRITE,XTERM);
6919
6920         case KEY_tr:
6921             s = scan_trans(s);
6922             TERM(sublex_start());
6923
6924         case KEY_tell:
6925             UNI(OP_TELL);
6926
6927         case KEY_telldir:
6928             UNI(OP_TELLDIR);
6929
6930         case KEY_tie:
6931             LOP(OP_TIE,XTERM);
6932
6933         case KEY_tied:
6934             UNI(OP_TIED);
6935
6936         case KEY_time:
6937             FUN0(OP_TIME);
6938
6939         case KEY_times:
6940             FUN0(OP_TMS);
6941
6942         case KEY_truncate:
6943             LOP(OP_TRUNCATE,XTERM);
6944
6945         case KEY_uc:
6946             UNI(OP_UC);
6947
6948         case KEY_ucfirst:
6949             UNI(OP_UCFIRST);
6950
6951         case KEY_untie:
6952             UNI(OP_UNTIE);
6953
6954         case KEY_until:
6955             pl_yylval.ival = CopLINE(PL_curcop);
6956             OPERATOR(UNTIL);
6957
6958         case KEY_unless:
6959             pl_yylval.ival = CopLINE(PL_curcop);
6960             OPERATOR(UNLESS);
6961
6962         case KEY_unlink:
6963             LOP(OP_UNLINK,XTERM);
6964
6965         case KEY_undef:
6966             UNIDOR(OP_UNDEF);
6967
6968         case KEY_unpack:
6969             LOP(OP_UNPACK,XTERM);
6970
6971         case KEY_utime:
6972             LOP(OP_UTIME,XTERM);
6973
6974         case KEY_umask:
6975             UNIDOR(OP_UMASK);
6976
6977         case KEY_unshift:
6978             LOP(OP_UNSHIFT,XTERM);
6979
6980         case KEY_use:
6981             s = tokenize_use(1, s);
6982             OPERATOR(USE);
6983
6984         case KEY_values:
6985             UNI(OP_VALUES);
6986
6987         case KEY_vec:
6988             LOP(OP_VEC,XTERM);
6989
6990         case KEY_when:
6991             pl_yylval.ival = CopLINE(PL_curcop);
6992             OPERATOR(WHEN);
6993
6994         case KEY_while:
6995             pl_yylval.ival = CopLINE(PL_curcop);
6996             OPERATOR(WHILE);
6997
6998         case KEY_warn:
6999             PL_hints |= HINT_BLOCK_SCOPE;
7000             LOP(OP_WARN,XTERM);
7001
7002         case KEY_wait:
7003             FUN0(OP_WAIT);
7004
7005         case KEY_waitpid:
7006             LOP(OP_WAITPID,XTERM);
7007
7008         case KEY_wantarray:
7009             FUN0(OP_WANTARRAY);
7010
7011         case KEY_write:
7012 #ifdef EBCDIC
7013         {
7014             char ctl_l[2];
7015             ctl_l[0] = toCTRL('L');
7016             ctl_l[1] = '\0';
7017             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7018         }
7019 #else
7020             /* Make sure $^L is defined */
7021             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7022 #endif
7023             UNI(OP_ENTERWRITE);
7024
7025         case KEY_x:
7026             if (PL_expect == XOPERATOR)
7027                 Mop(OP_REPEAT);
7028             check_uni();
7029             goto just_a_word;
7030
7031         case KEY_xor:
7032             pl_yylval.ival = OP_XOR;
7033             OPERATOR(OROP);
7034
7035         case KEY_y:
7036             s = scan_trans(s);
7037             TERM(sublex_start());
7038         }
7039     }}
7040 }
7041 #ifdef __SC__
7042 #pragma segment Main
7043 #endif
7044
7045 static int
7046 S_pending_ident(pTHX)
7047 {
7048     dVAR;
7049     register char *d;
7050     PADOFFSET tmp = 0;
7051     /* pit holds the identifier we read and pending_ident is reset */
7052     char pit = PL_pending_ident;
7053     const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7054     /* All routes through this function want to know if there is a colon.  */
7055     const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7056     PL_pending_ident = 0;
7057
7058     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7059     DEBUG_T({ PerlIO_printf(Perl_debug_log,
7060           "### Pending identifier '%s'\n", PL_tokenbuf); });
7061
7062     /* if we're in a my(), we can't allow dynamics here.
7063        $foo'bar has already been turned into $foo::bar, so
7064        just check for colons.
7065
7066        if it's a legal name, the OP is a PADANY.
7067     */
7068     if (PL_in_my) {
7069         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
7070             if (has_colon)
7071                 yyerror(Perl_form(aTHX_ "No package name allowed for "
7072                                   "variable %s in \"our\"",
7073                                   PL_tokenbuf));
7074             tmp = allocmy(PL_tokenbuf);
7075         }
7076         else {
7077             if (has_colon)
7078                 yyerror(Perl_form(aTHX_ PL_no_myglob,
7079                             PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7080
7081             pl_yylval.opval = newOP(OP_PADANY, 0);
7082             pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7083             return PRIVATEREF;
7084         }
7085     }
7086
7087     /*
7088        build the ops for accesses to a my() variable.
7089
7090        Deny my($a) or my($b) in a sort block, *if* $a or $b is
7091        then used in a comparison.  This catches most, but not
7092        all cases.  For instance, it catches
7093            sort { my($a); $a <=> $b }
7094        but not
7095            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7096        (although why you'd do that is anyone's guess).
7097     */
7098
7099     if (!has_colon) {
7100         if (!PL_in_my)
7101             tmp = pad_findmy(PL_tokenbuf);
7102         if (tmp != NOT_IN_PAD) {
7103             /* might be an "our" variable" */
7104             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7105                 /* build ops for a bareword */
7106                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
7107                 HEK * const stashname = HvNAME_HEK(stash);
7108                 SV *  const sym = newSVhek(stashname);
7109                 sv_catpvs(sym, "::");
7110                 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7111                 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7112                 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7113                 gv_fetchsv(sym,
7114                     (PL_in_eval
7115                         ? (GV_ADDMULTI | GV_ADDINEVAL)
7116                         : GV_ADDMULTI
7117                     ),
7118                     ((PL_tokenbuf[0] == '$') ? SVt_PV
7119                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7120                      : SVt_PVHV));
7121                 return WORD;
7122             }
7123
7124             /* if it's a sort block and they're naming $a or $b */
7125             if (PL_last_lop_op == OP_SORT &&
7126                 PL_tokenbuf[0] == '$' &&
7127                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7128                 && !PL_tokenbuf[2])
7129             {
7130                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7131                      d < PL_bufend && *d != '\n';
7132                      d++)
7133                 {
7134                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7135                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7136                               PL_tokenbuf);
7137                     }
7138                 }
7139             }
7140
7141             pl_yylval.opval = newOP(OP_PADANY, 0);
7142             pl_yylval.opval->op_targ = tmp;
7143             return PRIVATEREF;
7144         }
7145     }
7146
7147     /*
7148        Whine if they've said @foo in a doublequoted string,
7149        and @foo isn't a variable we can find in the symbol
7150        table.
7151     */
7152     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7153         GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7154                                          SVt_PVAV);
7155         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7156                 && ckWARN(WARN_AMBIGUOUS)
7157                 /* DO NOT warn for @- and @+ */
7158                 && !( PL_tokenbuf[2] == '\0' &&
7159                     ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7160            )
7161         {
7162             /* Downgraded from fatal to warning 20000522 mjd */
7163             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7164                         "Possible unintended interpolation of %s in string",
7165                          PL_tokenbuf);
7166         }
7167     }
7168
7169     /* build ops for a bareword */
7170     pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7171                                                       tokenbuf_len - 1));
7172     pl_yylval.opval->op_private = OPpCONST_ENTERED;
7173     gv_fetchpvn_flags(
7174             PL_tokenbuf + 1, tokenbuf_len - 1,
7175             /* If the identifier refers to a stash, don't autovivify it.
7176              * Change 24660 had the side effect of causing symbol table
7177              * hashes to always be defined, even if they were freshly
7178              * created and the only reference in the entire program was
7179              * the single statement with the defined %foo::bar:: test.
7180              * It appears that all code in the wild doing this actually
7181              * wants to know whether sub-packages have been loaded, so
7182              * by avoiding auto-vivifying symbol tables, we ensure that
7183              * defined %foo::bar:: continues to be false, and the existing
7184              * tests still give the expected answers, even though what
7185              * they're actually testing has now changed subtly.
7186              */
7187             (*PL_tokenbuf == '%'
7188              && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7189              && d[-1] == ':'
7190              ? 0
7191              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7192             ((PL_tokenbuf[0] == '$') ? SVt_PV
7193              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7194              : SVt_PVHV));
7195     return WORD;
7196 }
7197
7198 /*
7199  *  The following code was generated by perl_keyword.pl.
7200  */
7201
7202 I32
7203 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7204 {
7205     dVAR;
7206
7207     PERL_ARGS_ASSERT_KEYWORD;
7208
7209   switch (len)
7210   {
7211     case 1: /* 5 tokens of length 1 */
7212       switch (name[0])
7213       {
7214         case 'm':
7215           {                                       /* m          */
7216             return KEY_m;
7217           }
7218
7219         case 'q':
7220           {                                       /* q          */
7221             return KEY_q;
7222           }
7223
7224         case 's':
7225           {                                       /* s          */
7226             return KEY_s;
7227           }
7228
7229         case 'x':
7230           {                                       /* x          */
7231             return -KEY_x;
7232           }
7233
7234         case 'y':
7235           {                                       /* y          */
7236             return KEY_y;
7237           }
7238
7239         default:
7240           goto unknown;
7241       }
7242
7243     case 2: /* 18 tokens of length 2 */
7244       switch (name[0])
7245       {
7246         case 'd':
7247           if (name[1] == 'o')
7248           {                                       /* do         */
7249             return KEY_do;
7250           }
7251
7252           goto unknown;
7253
7254         case 'e':
7255           if (name[1] == 'q')
7256           {                                       /* eq         */
7257             return -KEY_eq;
7258           }
7259
7260           goto unknown;
7261
7262         case 'g':
7263           switch (name[1])
7264           {
7265             case 'e':
7266               {                                   /* ge         */
7267                 return -KEY_ge;
7268               }
7269
7270             case 't':
7271               {                                   /* gt         */
7272                 return -KEY_gt;
7273               }
7274
7275             default:
7276               goto unknown;
7277           }
7278
7279         case 'i':
7280           if (name[1] == 'f')
7281           {                                       /* if         */
7282             return KEY_if;
7283           }
7284
7285           goto unknown;
7286
7287         case 'l':
7288           switch (name[1])
7289           {
7290             case 'c':
7291               {                                   /* lc         */
7292                 return -KEY_lc;
7293               }
7294
7295             case 'e':
7296               {                                   /* le         */
7297                 return -KEY_le;
7298               }
7299
7300             case 't':
7301               {                                   /* lt         */
7302                 return -KEY_lt;
7303               }
7304
7305             default:
7306               goto unknown;
7307           }
7308
7309         case 'm':
7310           if (name[1] == 'y')
7311           {                                       /* my         */
7312             return KEY_my;
7313           }
7314
7315           goto unknown;
7316
7317         case 'n':
7318           switch (name[1])
7319           {
7320             case 'e':
7321               {                                   /* ne         */
7322                 return -KEY_ne;
7323               }
7324
7325             case 'o':
7326               {                                   /* no         */
7327                 return KEY_no;
7328               }
7329
7330             default:
7331               goto unknown;
7332           }
7333
7334         case 'o':
7335           if (name[1] == 'r')
7336           {                                       /* or         */
7337             return -KEY_or;
7338           }
7339
7340           goto unknown;
7341
7342         case 'q':
7343           switch (name[1])
7344           {
7345             case 'q':
7346               {                                   /* qq         */
7347                 return KEY_qq;
7348               }
7349
7350             case 'r':
7351               {                                   /* qr         */
7352                 return KEY_qr;
7353               }
7354
7355             case 'w':
7356               {                                   /* qw         */
7357                 return KEY_qw;
7358               }
7359
7360             case 'x':
7361               {                                   /* qx         */
7362                 return KEY_qx;
7363               }
7364
7365             default:
7366               goto unknown;
7367           }
7368
7369         case 't':
7370           if (name[1] == 'r')
7371           {                                       /* tr         */
7372             return KEY_tr;
7373           }
7374
7375           goto unknown;
7376
7377         case 'u':
7378           if (name[1] == 'c')
7379           {                                       /* uc         */
7380             return -KEY_uc;
7381           }
7382
7383           goto unknown;
7384
7385         default:
7386           goto unknown;
7387       }
7388
7389     case 3: /* 29 tokens of length 3 */
7390       switch (name[0])
7391       {
7392         case 'E':
7393           if (name[1] == 'N' &&
7394               name[2] == 'D')
7395           {                                       /* END        */
7396             return KEY_END;
7397           }
7398
7399           goto unknown;
7400
7401         case 'a':
7402           switch (name[1])
7403           {
7404             case 'b':
7405               if (name[2] == 's')
7406               {                                   /* abs        */
7407                 return -KEY_abs;
7408               }
7409
7410               goto unknown;
7411
7412             case 'n':
7413               if (name[2] == 'd')
7414               {                                   /* and        */
7415                 return -KEY_and;
7416               }
7417
7418               goto unknown;
7419
7420             default:
7421               goto unknown;
7422           }
7423
7424         case 'c':
7425           switch (name[1])
7426           {
7427             case 'h':
7428               if (name[2] == 'r')
7429               {                                   /* chr        */
7430                 return -KEY_chr;
7431               }
7432
7433               goto unknown;
7434
7435             case 'm':
7436               if (name[2] == 'p')
7437               {                                   /* cmp        */
7438                 return -KEY_cmp;
7439               }
7440
7441               goto unknown;
7442
7443             case 'o':
7444               if (name[2] == 's')
7445               {                                   /* cos        */
7446                 return -KEY_cos;
7447               }
7448
7449               goto unknown;
7450
7451             default:
7452               goto unknown;
7453           }
7454
7455         case 'd':
7456           if (name[1] == 'i' &&
7457               name[2] == 'e')
7458           {                                       /* die        */
7459             return -KEY_die;
7460           }
7461
7462           goto unknown;
7463
7464         case 'e':
7465           switch (name[1])
7466           {
7467             case 'o':
7468               if (name[2] == 'f')
7469               {                                   /* eof        */
7470                 return -KEY_eof;
7471               }
7472
7473               goto unknown;
7474
7475             case 'x':
7476               if (name[2] == 'p')
7477               {                                   /* exp        */
7478                 return -KEY_exp;
7479               }
7480
7481               goto unknown;
7482
7483             default:
7484               goto unknown;
7485           }
7486
7487         case 'f':
7488           if (name[1] == 'o' &&
7489               name[2] == 'r')
7490           {                                       /* for        */
7491             return KEY_for;
7492           }
7493
7494           goto unknown;
7495
7496         case 'h':
7497           if (name[1] == 'e' &&
7498               name[2] == 'x')
7499           {                                       /* hex        */
7500             return -KEY_hex;
7501           }
7502
7503           goto unknown;
7504
7505         case 'i':
7506           if (name[1] == 'n' &&
7507               name[2] == 't')
7508           {                                       /* int        */
7509             return -KEY_int;
7510           }
7511
7512           goto unknown;
7513
7514         case 'l':
7515           if (name[1] == 'o' &&
7516               name[2] == 'g')
7517           {                                       /* log        */
7518             return -KEY_log;
7519           }
7520
7521           goto unknown;
7522
7523         case 'm':
7524           if (name[1] == 'a' &&
7525               name[2] == 'p')
7526           {                                       /* map        */
7527             return KEY_map;
7528           }
7529
7530           goto unknown;
7531
7532         case 'n':
7533           if (name[1] == 'o' &&
7534               name[2] == 't')
7535           {                                       /* not        */
7536             return -KEY_not;
7537           }
7538
7539           goto unknown;
7540
7541         case 'o':
7542           switch (name[1])
7543           {
7544             case 'c':
7545               if (name[2] == 't')
7546               {                                   /* oct        */
7547                 return -KEY_oct;
7548               }
7549
7550               goto unknown;
7551
7552             case 'r':
7553               if (name[2] == 'd')
7554               {                                   /* ord        */
7555                 return -KEY_ord;
7556               }
7557
7558               goto unknown;
7559
7560             case 'u':
7561               if (name[2] == 'r')
7562               {                                   /* our        */
7563                 return KEY_our;
7564               }
7565
7566               goto unknown;
7567
7568             default:
7569               goto unknown;
7570           }
7571
7572         case 'p':
7573           if (name[1] == 'o')
7574           {
7575             switch (name[2])
7576             {
7577               case 'p':
7578                 {                                 /* pop        */
7579                   return -KEY_pop;
7580                 }
7581
7582               case 's':
7583                 {                                 /* pos        */
7584                   return KEY_pos;
7585                 }
7586
7587               default:
7588                 goto unknown;
7589             }
7590           }
7591
7592           goto unknown;
7593
7594         case 'r':
7595           if (name[1] == 'e' &&
7596               name[2] == 'f')
7597           {                                       /* ref        */
7598             return -KEY_ref;
7599           }
7600
7601           goto unknown;
7602
7603         case 's':
7604           switch (name[1])
7605           {
7606             case 'a':
7607               if (name[2] == 'y')
7608               {                                   /* say        */
7609                 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7610               }
7611
7612               goto unknown;
7613
7614             case 'i':
7615               if (name[2] == 'n')
7616               {                                   /* sin        */
7617                 return -KEY_sin;
7618               }
7619
7620               goto unknown;
7621
7622             case 'u':
7623               if (name[2] == 'b')
7624               {                                   /* sub        */
7625                 return KEY_sub;
7626               }
7627
7628               goto unknown;
7629
7630             default:
7631               goto unknown;
7632           }
7633
7634         case 't':
7635           if (name[1] == 'i' &&
7636               name[2] == 'e')
7637           {                                       /* tie        */
7638             return KEY_tie;
7639           }
7640
7641           goto unknown;
7642
7643         case 'u':
7644           if (name[1] == 's' &&
7645               name[2] == 'e')
7646           {                                       /* use        */
7647             return KEY_use;
7648           }
7649
7650           goto unknown;
7651
7652         case 'v':
7653           if (name[1] == 'e' &&
7654               name[2] == 'c')
7655           {                                       /* vec        */
7656             return -KEY_vec;
7657           }
7658
7659           goto unknown;
7660
7661         case 'x':
7662           if (name[1] == 'o' &&
7663               name[2] == 'r')
7664           {                                       /* xor        */
7665             return -KEY_xor;
7666           }
7667
7668           goto unknown;
7669
7670         default:
7671           goto unknown;
7672       }
7673
7674     case 4: /* 41 tokens of length 4 */
7675       switch (name[0])
7676       {
7677         case 'C':
7678           if (name[1] == 'O' &&
7679               name[2] == 'R' &&
7680               name[3] == 'E')
7681           {                                       /* CORE       */
7682             return -KEY_CORE;
7683           }
7684
7685           goto unknown;
7686
7687         case 'I':
7688           if (name[1] == 'N' &&
7689               name[2] == 'I' &&
7690               name[3] == 'T')
7691           {                                       /* INIT       */
7692             return KEY_INIT;
7693           }
7694
7695           goto unknown;
7696
7697         case 'b':
7698           if (name[1] == 'i' &&
7699               name[2] == 'n' &&
7700               name[3] == 'd')
7701           {                                       /* bind       */
7702             return -KEY_bind;
7703           }
7704
7705           goto unknown;
7706
7707         case 'c':
7708           if (name[1] == 'h' &&
7709               name[2] == 'o' &&
7710               name[3] == 'p')
7711           {                                       /* chop       */
7712             return -KEY_chop;
7713           }
7714
7715           goto unknown;
7716
7717         case 'd':
7718           if (name[1] == 'u' &&
7719               name[2] == 'm' &&
7720               name[3] == 'p')
7721           {                                       /* dump       */
7722             return -KEY_dump;
7723           }
7724
7725           goto unknown;
7726
7727         case 'e':
7728           switch (name[1])
7729           {
7730             case 'a':
7731               if (name[2] == 'c' &&
7732                   name[3] == 'h')
7733               {                                   /* each       */
7734                 return -KEY_each;
7735               }
7736
7737               goto unknown;
7738
7739             case 'l':
7740               if (name[2] == 's' &&
7741                   name[3] == 'e')
7742               {                                   /* else       */
7743                 return KEY_else;
7744               }
7745
7746               goto unknown;
7747
7748             case 'v':
7749               if (name[2] == 'a' &&
7750                   name[3] == 'l')
7751               {                                   /* eval       */
7752                 return KEY_eval;
7753               }
7754
7755               goto unknown;
7756
7757             case 'x':
7758               switch (name[2])
7759               {
7760                 case 'e':
7761                   if (name[3] == 'c')
7762                   {                               /* exec       */
7763                     return -KEY_exec;
7764                   }
7765
7766                   goto unknown;
7767
7768                 case 'i':
7769                   if (name[3] == 't')
7770                   {                               /* exit       */
7771                     return -KEY_exit;
7772                   }
7773
7774                   goto unknown;
7775
7776                 default:
7777                   goto unknown;
7778               }
7779
7780             default:
7781               goto unknown;
7782           }
7783
7784         case 'f':
7785           if (name[1] == 'o' &&
7786               name[2] == 'r' &&
7787               name[3] == 'k')
7788           {                                       /* fork       */
7789             return -KEY_fork;
7790           }
7791
7792           goto unknown;
7793
7794         case 'g':
7795           switch (name[1])
7796           {
7797             case 'e':
7798               if (name[2] == 't' &&
7799                   name[3] == 'c')
7800               {                                   /* getc       */
7801                 return -KEY_getc;
7802               }
7803
7804               goto unknown;
7805
7806             case 'l':
7807               if (name[2] == 'o' &&
7808                   name[3] == 'b')
7809               {                                   /* glob       */
7810                 return KEY_glob;
7811               }
7812
7813               goto unknown;
7814
7815             case 'o':
7816               if (name[2] == 't' &&
7817                   name[3] == 'o')
7818               {                                   /* goto       */
7819                 return KEY_goto;
7820               }
7821
7822               goto unknown;
7823
7824             case 'r':
7825               if (name[2] == 'e' &&
7826                   name[3] == 'p')
7827               {                                   /* grep       */
7828                 return KEY_grep;
7829               }
7830
7831               goto unknown;
7832
7833             default:
7834               goto unknown;
7835           }
7836
7837         case 'j':
7838           if (name[1] == 'o' &&
7839               name[2] == 'i' &&
7840               name[3] == 'n')
7841           {                                       /* join       */
7842             return -KEY_join;
7843           }
7844
7845           goto unknown;
7846
7847         case 'k':
7848           switch (name[1])
7849           {
7850             case 'e':
7851               if (name[2] == 'y' &&
7852                   name[3] == 's')
7853               {                                   /* keys       */
7854                 return -KEY_keys;
7855               }
7856
7857               goto unknown;
7858
7859             case 'i':
7860               if (name[2] == 'l' &&
7861                   name[3] == 'l')
7862               {                                   /* kill       */
7863                 return -KEY_kill;
7864               }
7865
7866               goto unknown;
7867
7868             default:
7869               goto unknown;
7870           }
7871
7872         case 'l':
7873           switch (name[1])
7874           {
7875             case 'a':
7876               if (name[2] == 's' &&
7877                   name[3] == 't')
7878               {                                   /* last       */
7879                 return KEY_last;
7880               }
7881
7882               goto unknown;
7883
7884             case 'i':
7885               if (name[2] == 'n' &&
7886                   name[3] == 'k')
7887               {                                   /* link       */
7888                 return -KEY_link;
7889               }
7890
7891               goto unknown;
7892
7893             case 'o':
7894               if (name[2] == 'c' &&
7895                   name[3] == 'k')
7896               {                                   /* lock       */
7897                 return -KEY_lock;
7898               }
7899
7900               goto unknown;
7901
7902             default:
7903               goto unknown;
7904           }
7905
7906         case 'n':
7907           if (name[1] == 'e' &&
7908               name[2] == 'x' &&
7909               name[3] == 't')
7910           {                                       /* next       */
7911             return KEY_next;
7912           }
7913
7914           goto unknown;
7915
7916         case 'o':
7917           if (name[1] == 'p' &&
7918               name[2] == 'e' &&
7919               name[3] == 'n')
7920           {                                       /* open       */
7921             return -KEY_open;
7922           }
7923
7924           goto unknown;
7925
7926         case 'p':
7927           switch (name[1])
7928           {
7929             case 'a':
7930               if (name[2] == 'c' &&
7931                   name[3] == 'k')
7932               {                                   /* pack       */
7933                 return -KEY_pack;
7934               }
7935
7936               goto unknown;
7937
7938             case 'i':
7939               if (name[2] == 'p' &&
7940                   name[3] == 'e')
7941               {                                   /* pipe       */
7942                 return -KEY_pipe;
7943               }
7944
7945               goto unknown;
7946
7947             case 'u':
7948               if (name[2] == 's' &&
7949                   name[3] == 'h')
7950               {                                   /* push       */
7951                 return -KEY_push;
7952               }
7953
7954               goto unknown;
7955
7956             default:
7957               goto unknown;
7958           }
7959
7960         case 'r':
7961           switch (name[1])
7962           {
7963             case 'a':
7964               if (name[2] == 'n' &&
7965                   name[3] == 'd')
7966               {                                   /* rand       */
7967                 return -KEY_rand;
7968               }
7969
7970               goto unknown;
7971
7972             case 'e':
7973               switch (name[2])
7974               {
7975                 case 'a':
7976                   if (name[3] == 'd')
7977                   {                               /* read       */
7978                     return -KEY_read;
7979                   }
7980
7981                   goto unknown;
7982
7983                 case 'c':
7984                   if (name[3] == 'v')
7985                   {                               /* recv       */
7986                     return -KEY_recv;
7987                   }
7988
7989                   goto unknown;
7990
7991                 case 'd':
7992                   if (name[3] == 'o')
7993                   {                               /* redo       */
7994                     return KEY_redo;
7995                   }
7996
7997                   goto unknown;
7998
7999                 default:
8000                   goto unknown;
8001               }
8002
8003             default:
8004               goto unknown;
8005           }
8006
8007         case 's':
8008           switch (name[1])
8009           {
8010             case 'e':
8011               switch (name[2])
8012               {
8013                 case 'e':
8014                   if (name[3] == 'k')
8015                   {                               /* seek       */
8016                     return -KEY_seek;
8017                   }
8018
8019                   goto unknown;
8020
8021                 case 'n':
8022                   if (name[3] == 'd')
8023                   {                               /* send       */
8024                     return -KEY_send;
8025                   }
8026
8027                   goto unknown;
8028
8029                 default:
8030                   goto unknown;
8031               }
8032
8033             case 'o':
8034               if (name[2] == 'r' &&
8035                   name[3] == 't')
8036               {                                   /* sort       */
8037                 return KEY_sort;
8038               }
8039
8040               goto unknown;
8041
8042             case 'q':
8043               if (name[2] == 'r' &&
8044                   name[3] == 't')
8045               {                                   /* sqrt       */
8046                 return -KEY_sqrt;
8047               }
8048
8049               goto unknown;
8050
8051             case 't':
8052               if (name[2] == 'a' &&
8053                   name[3] == 't')
8054               {                                   /* stat       */
8055                 return -KEY_stat;
8056               }
8057
8058               goto unknown;
8059
8060             default:
8061               goto unknown;
8062           }
8063
8064         case 't':
8065           switch (name[1])
8066           {
8067             case 'e':
8068               if (name[2] == 'l' &&
8069                   name[3] == 'l')
8070               {                                   /* tell       */
8071                 return -KEY_tell;
8072               }
8073
8074               goto unknown;
8075
8076             case 'i':
8077               switch (name[2])
8078               {
8079                 case 'e':
8080                   if (name[3] == 'd')
8081                   {                               /* tied       */
8082                     return KEY_tied;
8083                   }
8084
8085                   goto unknown;
8086
8087                 case 'm':
8088                   if (name[3] == 'e')
8089                   {                               /* time       */
8090                     return -KEY_time;
8091                   }
8092
8093                   goto unknown;
8094
8095                 default:
8096                   goto unknown;
8097               }
8098
8099             default:
8100               goto unknown;
8101           }
8102
8103         case 'w':
8104           switch (name[1])
8105           {
8106             case 'a':
8107               switch (name[2])
8108               {
8109                 case 'i':
8110                   if (name[3] == 't')
8111                   {                               /* wait       */
8112                     return -KEY_wait;
8113                   }
8114
8115                   goto unknown;
8116
8117                 case 'r':
8118                   if (name[3] == 'n')
8119                   {                               /* warn       */
8120                     return -KEY_warn;
8121                   }
8122
8123                   goto unknown;
8124
8125                 default:
8126                   goto unknown;
8127               }
8128
8129             case 'h':
8130               if (name[2] == 'e' &&
8131                   name[3] == 'n')
8132               {                                   /* when       */
8133                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8134               }
8135
8136               goto unknown;
8137
8138             default:
8139               goto unknown;
8140           }
8141
8142         default:
8143           goto unknown;
8144       }
8145
8146     case 5: /* 39 tokens of length 5 */
8147       switch (name[0])
8148       {
8149         case 'B':
8150           if (name[1] == 'E' &&
8151               name[2] == 'G' &&
8152               name[3] == 'I' &&
8153               name[4] == 'N')
8154           {                                       /* BEGIN      */
8155             return KEY_BEGIN;
8156           }
8157
8158           goto unknown;
8159
8160         case 'C':
8161           if (name[1] == 'H' &&
8162               name[2] == 'E' &&
8163               name[3] == 'C' &&
8164               name[4] == 'K')
8165           {                                       /* CHECK      */
8166             return KEY_CHECK;
8167           }
8168
8169           goto unknown;
8170
8171         case 'a':
8172           switch (name[1])
8173           {
8174             case 'l':
8175               if (name[2] == 'a' &&
8176                   name[3] == 'r' &&
8177                   name[4] == 'm')
8178               {                                   /* alarm      */
8179                 return -KEY_alarm;
8180               }
8181
8182               goto unknown;
8183
8184             case 't':
8185               if (name[2] == 'a' &&
8186                   name[3] == 'n' &&
8187                   name[4] == '2')
8188               {                                   /* atan2      */
8189                 return -KEY_atan2;
8190               }
8191
8192               goto unknown;
8193
8194             default:
8195               goto unknown;
8196           }
8197
8198         case 'b':
8199           switch (name[1])
8200           {
8201             case 'l':
8202               if (name[2] == 'e' &&
8203                   name[3] == 's' &&
8204                   name[4] == 's')
8205               {                                   /* bless      */
8206                 return -KEY_bless;
8207               }
8208
8209               goto unknown;
8210
8211             case 'r':
8212               if (name[2] == 'e' &&
8213                   name[3] == 'a' &&
8214                   name[4] == 'k')
8215               {                                   /* break      */
8216                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8217               }
8218
8219               goto unknown;
8220
8221             default:
8222               goto unknown;
8223           }
8224
8225         case 'c':
8226           switch (name[1])
8227           {
8228             case 'h':
8229               switch (name[2])
8230               {
8231                 case 'd':
8232                   if (name[3] == 'i' &&
8233                       name[4] == 'r')
8234                   {                               /* chdir      */
8235                     return -KEY_chdir;
8236                   }
8237
8238                   goto unknown;
8239
8240                 case 'm':
8241                   if (name[3] == 'o' &&
8242                       name[4] == 'd')
8243                   {                               /* chmod      */
8244                     return -KEY_chmod;
8245                   }
8246
8247                   goto unknown;
8248
8249                 case 'o':
8250                   switch (name[3])
8251                   {
8252                     case 'm':
8253                       if (name[4] == 'p')
8254                       {                           /* chomp      */
8255                         return -KEY_chomp;
8256                       }
8257
8258                       goto unknown;
8259
8260                     case 'w':
8261                       if (name[4] == 'n')
8262                       {                           /* chown      */
8263                         return -KEY_chown;
8264                       }
8265
8266                       goto unknown;
8267
8268                     default:
8269                       goto unknown;
8270                   }
8271
8272                 default:
8273                   goto unknown;
8274               }
8275
8276             case 'l':
8277               if (name[2] == 'o' &&
8278                   name[3] == 's' &&
8279                   name[4] == 'e')
8280               {                                   /* close      */
8281                 return -KEY_close;
8282               }
8283
8284               goto unknown;
8285
8286             case 'r':
8287               if (name[2] == 'y' &&
8288                   name[3] == 'p' &&
8289                   name[4] == 't')
8290               {                                   /* crypt      */
8291                 return -KEY_crypt;
8292               }
8293
8294               goto unknown;
8295
8296             default:
8297               goto unknown;
8298           }
8299
8300         case 'e':
8301           if (name[1] == 'l' &&
8302               name[2] == 's' &&
8303               name[3] == 'i' &&
8304               name[4] == 'f')
8305           {                                       /* elsif      */
8306             return KEY_elsif;
8307           }
8308
8309           goto unknown;
8310
8311         case 'f':
8312           switch (name[1])
8313           {
8314             case 'c':
8315               if (name[2] == 'n' &&
8316                   name[3] == 't' &&
8317                   name[4] == 'l')
8318               {                                   /* fcntl      */
8319                 return -KEY_fcntl;
8320               }
8321
8322               goto unknown;
8323
8324             case 'l':
8325               if (name[2] == 'o' &&
8326                   name[3] == 'c' &&
8327                   name[4] == 'k')
8328               {                                   /* flock      */
8329                 return -KEY_flock;
8330               }
8331
8332               goto unknown;
8333
8334             default:
8335               goto unknown;
8336           }
8337
8338         case 'g':
8339           if (name[1] == 'i' &&
8340               name[2] == 'v' &&
8341               name[3] == 'e' &&
8342               name[4] == 'n')
8343           {                                       /* given      */
8344             return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8345           }
8346
8347           goto unknown;
8348
8349         case 'i':
8350           switch (name[1])
8351           {
8352             case 'n':
8353               if (name[2] == 'd' &&
8354                   name[3] == 'e' &&
8355                   name[4] == 'x')
8356               {                                   /* index      */
8357                 return -KEY_index;
8358               }
8359
8360               goto unknown;
8361
8362             case 'o':
8363               if (name[2] == 'c' &&
8364                   name[3] == 't' &&
8365                   name[4] == 'l')
8366               {                                   /* ioctl      */
8367                 return -KEY_ioctl;
8368               }
8369
8370               goto unknown;
8371
8372             default:
8373               goto unknown;
8374           }
8375
8376         case 'l':
8377           switch (name[1])
8378           {
8379             case 'o':
8380               if (name[2] == 'c' &&
8381                   name[3] == 'a' &&
8382                   name[4] == 'l')
8383               {                                   /* local      */
8384                 return KEY_local;
8385               }
8386
8387               goto unknown;
8388
8389             case 's':
8390               if (name[2] == 't' &&
8391                   name[3] == 'a' &&
8392                   name[4] == 't')
8393               {                                   /* lstat      */
8394                 return -KEY_lstat;
8395               }
8396
8397               goto unknown;
8398
8399             default:
8400               goto unknown;
8401           }
8402
8403         case 'm':
8404           if (name[1] == 'k' &&
8405               name[2] == 'd' &&
8406               name[3] == 'i' &&
8407               name[4] == 'r')
8408           {                                       /* mkdir      */
8409             return -KEY_mkdir;
8410           }
8411
8412           goto unknown;
8413
8414         case 'p':
8415           if (name[1] == 'r' &&
8416               name[2] == 'i' &&
8417               name[3] == 'n' &&
8418               name[4] == 't')
8419           {                                       /* print      */
8420             return KEY_print;
8421           }
8422
8423           goto unknown;
8424
8425         case 'r':
8426           switch (name[1])
8427           {
8428             case 'e':
8429               if (name[2] == 's' &&
8430                   name[3] == 'e' &&
8431                   name[4] == 't')
8432               {                                   /* reset      */
8433                 return -KEY_reset;
8434               }
8435
8436               goto unknown;
8437
8438             case 'm':
8439               if (name[2] == 'd' &&
8440                   name[3] == 'i' &&
8441                   name[4] == 'r')
8442               {                                   /* rmdir      */
8443                 return -KEY_rmdir;
8444               }
8445
8446               goto unknown;
8447
8448             default:
8449               goto unknown;
8450           }
8451
8452         case 's':
8453           switch (name[1])
8454           {
8455             case 'e':
8456               if (name[2] == 'm' &&
8457                   name[3] == 'o' &&
8458                   name[4] == 'p')
8459               {                                   /* semop      */
8460                 return -KEY_semop;
8461               }
8462
8463               goto unknown;
8464
8465             case 'h':
8466               if (name[2] == 'i' &&
8467                   name[3] == 'f' &&
8468                   name[4] == 't')
8469               {                                   /* shift      */
8470                 return -KEY_shift;
8471               }
8472
8473               goto unknown;
8474
8475             case 'l':
8476               if (name[2] == 'e' &&
8477                   name[3] == 'e' &&
8478                   name[4] == 'p')
8479               {                                   /* sleep      */
8480                 return -KEY_sleep;
8481               }
8482
8483               goto unknown;
8484
8485             case 'p':
8486               if (name[2] == 'l' &&
8487                   name[3] == 'i' &&
8488                   name[4] == 't')
8489               {                                   /* split      */
8490                 return KEY_split;
8491               }
8492
8493               goto unknown;
8494
8495             case 'r':
8496               if (name[2] == 'a' &&
8497                   name[3] == 'n' &&
8498                   name[4] == 'd')
8499               {                                   /* srand      */
8500                 return -KEY_srand;
8501               }
8502
8503               goto unknown;
8504
8505             case 't':
8506               switch (name[2])
8507               {
8508                 case 'a':
8509                   if (name[3] == 't' &&
8510                       name[4] == 'e')
8511                   {                               /* state      */
8512                     return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8513                   }
8514
8515                   goto unknown;
8516
8517                 case 'u':
8518                   if (name[3] == 'd' &&
8519                       name[4] == 'y')
8520                   {                               /* study      */
8521                     return KEY_study;
8522                   }
8523
8524                   goto unknown;
8525
8526                 default:
8527                   goto unknown;
8528               }
8529
8530             default:
8531               goto unknown;
8532           }
8533
8534         case 't':
8535           if (name[1] == 'i' &&
8536               name[2] == 'm' &&
8537               name[3] == 'e' &&
8538               name[4] == 's')
8539           {                                       /* times      */
8540             return -KEY_times;
8541           }
8542
8543           goto unknown;
8544
8545         case 'u':
8546           switch (name[1])
8547           {
8548             case 'm':
8549               if (name[2] == 'a' &&
8550                   name[3] == 's' &&
8551                   name[4] == 'k')
8552               {                                   /* umask      */
8553                 return -KEY_umask;
8554               }
8555
8556               goto unknown;
8557
8558             case 'n':
8559               switch (name[2])
8560               {
8561                 case 'd':
8562                   if (name[3] == 'e' &&
8563                       name[4] == 'f')
8564                   {                               /* undef      */
8565                     return KEY_undef;
8566                   }
8567
8568                   goto unknown;
8569
8570                 case 't':
8571                   if (name[3] == 'i')
8572                   {
8573                     switch (name[4])
8574                     {
8575                       case 'e':
8576                         {                         /* untie      */
8577                           return KEY_untie;
8578                         }
8579
8580                       case 'l':
8581                         {                         /* until      */
8582                           return KEY_until;
8583                         }
8584
8585                       default:
8586                         goto unknown;
8587                     }
8588                   }
8589
8590                   goto unknown;
8591
8592                 default:
8593                   goto unknown;
8594               }
8595
8596             case 't':
8597               if (name[2] == 'i' &&
8598                   name[3] == 'm' &&
8599                   name[4] == 'e')
8600               {                                   /* utime      */
8601                 return -KEY_utime;
8602               }
8603
8604               goto unknown;
8605
8606             default:
8607               goto unknown;
8608           }
8609
8610         case 'w':
8611           switch (name[1])
8612           {
8613             case 'h':
8614               if (name[2] == 'i' &&
8615                   name[3] == 'l' &&
8616                   name[4] == 'e')
8617               {                                   /* while      */
8618                 return KEY_while;
8619               }
8620
8621               goto unknown;
8622
8623             case 'r':
8624               if (name[2] == 'i' &&
8625                   name[3] == 't' &&
8626                   name[4] == 'e')
8627               {                                   /* write      */
8628                 return -KEY_write;
8629               }
8630
8631               goto unknown;
8632
8633             default:
8634               goto unknown;
8635           }
8636
8637         default:
8638           goto unknown;
8639       }
8640
8641     case 6: /* 33 tokens of length 6 */
8642       switch (name[0])
8643       {
8644         case 'a':
8645           if (name[1] == 'c' &&
8646               name[2] == 'c' &&
8647               name[3] == 'e' &&
8648               name[4] == 'p' &&
8649               name[5] == 't')
8650           {                                       /* accept     */
8651             return -KEY_accept;
8652           }
8653
8654           goto unknown;
8655
8656         case 'c':
8657           switch (name[1])
8658           {
8659             case 'a':
8660               if (name[2] == 'l' &&
8661                   name[3] == 'l' &&
8662                   name[4] == 'e' &&
8663                   name[5] == 'r')
8664               {                                   /* caller     */
8665                 return -KEY_caller;
8666               }
8667
8668               goto unknown;
8669
8670             case 'h':
8671               if (name[2] == 'r' &&
8672                   name[3] == 'o' &&
8673                   name[4] == 'o' &&
8674                   name[5] == 't')
8675               {                                   /* chroot     */
8676                 return -KEY_chroot;
8677               }
8678
8679               goto unknown;
8680
8681             default:
8682               goto unknown;
8683           }
8684
8685         case 'd':
8686           if (name[1] == 'e' &&
8687               name[2] == 'l' &&
8688               name[3] == 'e' &&
8689               name[4] == 't' &&
8690               name[5] == 'e')
8691           {                                       /* delete     */
8692             return KEY_delete;
8693           }
8694
8695           goto unknown;
8696
8697         case 'e':
8698           switch (name[1])
8699           {
8700             case 'l':
8701               if (name[2] == 's' &&
8702                   name[3] == 'e' &&
8703                   name[4] == 'i' &&
8704                   name[5] == 'f')
8705               {                                   /* elseif     */
8706                 if(ckWARN_d(WARN_SYNTAX))
8707                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8708               }
8709
8710               goto unknown;
8711
8712             case 'x':
8713               if (name[2] == 'i' &&
8714                   name[3] == 's' &&
8715                   name[4] == 't' &&
8716                   name[5] == 's')
8717               {                                   /* exists     */
8718                 return KEY_exists;
8719               }
8720
8721               goto unknown;
8722
8723             default:
8724               goto unknown;
8725           }
8726
8727         case 'f':
8728           switch (name[1])
8729           {
8730             case 'i':
8731               if (name[2] == 'l' &&
8732                   name[3] == 'e' &&
8733                   name[4] == 'n' &&
8734                   name[5] == 'o')
8735               {                                   /* fileno     */
8736                 return -KEY_fileno;
8737               }
8738
8739               goto unknown;
8740
8741             case 'o':
8742               if (name[2] == 'r' &&
8743                   name[3] == 'm' &&
8744                   name[4] == 'a' &&
8745                   name[5] == 't')
8746               {                                   /* format     */
8747                 return KEY_format;
8748               }
8749
8750               goto unknown;
8751
8752             default:
8753               goto unknown;
8754           }
8755
8756         case 'g':
8757           if (name[1] == 'm' &&
8758               name[2] == 't' &&
8759               name[3] == 'i' &&
8760               name[4] == 'm' &&
8761               name[5] == 'e')
8762           {                                       /* gmtime     */
8763             return -KEY_gmtime;
8764           }
8765
8766           goto unknown;
8767
8768         case 'l':
8769           switch (name[1])
8770           {
8771             case 'e':
8772               if (name[2] == 'n' &&
8773                   name[3] == 'g' &&
8774                   name[4] == 't' &&
8775                   name[5] == 'h')
8776               {                                   /* length     */
8777                 return -KEY_length;
8778               }
8779
8780               goto unknown;
8781
8782             case 'i':
8783               if (name[2] == 's' &&
8784                   name[3] == 't' &&
8785                   name[4] == 'e' &&
8786                   name[5] == 'n')
8787               {                                   /* listen     */
8788                 return -KEY_listen;
8789               }
8790
8791               goto unknown;
8792
8793             default:
8794               goto unknown;
8795           }
8796
8797         case 'm':
8798           if (name[1] == 's' &&
8799               name[2] == 'g')
8800           {
8801             switch (name[3])
8802             {
8803               case 'c':
8804                 if (name[4] == 't' &&
8805                     name[5] == 'l')
8806                 {                                 /* msgctl     */
8807                   return -KEY_msgctl;
8808                 }
8809
8810                 goto unknown;
8811
8812               case 'g':
8813                 if (name[4] == 'e' &&
8814                     name[5] == 't')
8815                 {                                 /* msgget     */
8816                   return -KEY_msgget;
8817                 }
8818
8819                 goto unknown;
8820
8821               case 'r':
8822                 if (name[4] == 'c' &&
8823                     name[5] == 'v')
8824                 {                                 /* msgrcv     */
8825                   return -KEY_msgrcv;
8826                 }
8827
8828                 goto unknown;
8829
8830               case 's':
8831                 if (name[4] == 'n' &&
8832                     name[5] == 'd')
8833                 {                                 /* msgsnd     */
8834                   return -KEY_msgsnd;
8835                 }
8836
8837                 goto unknown;
8838
8839               default:
8840                 goto unknown;
8841             }
8842           }
8843
8844           goto unknown;
8845
8846         case 'p':
8847           if (name[1] == 'r' &&
8848               name[2] == 'i' &&
8849               name[3] == 'n' &&
8850               name[4] == 't' &&
8851               name[5] == 'f')
8852           {                                       /* printf     */
8853             return KEY_printf;
8854           }
8855
8856           goto unknown;
8857
8858         case 'r':
8859           switch (name[1])
8860           {
8861             case 'e':
8862               switch (name[2])
8863               {
8864                 case 'n':
8865                   if (name[3] == 'a' &&
8866                       name[4] == 'm' &&
8867                       name[5] == 'e')
8868                   {                               /* rename     */
8869                     return -KEY_rename;
8870                   }
8871
8872                   goto unknown;
8873
8874                 case 't':
8875                   if (name[3] == 'u' &&
8876                       name[4] == 'r' &&
8877                       name[5] == 'n')
8878                   {                               /* return     */
8879                     return KEY_return;
8880                   }
8881
8882                   goto unknown;
8883
8884                 default:
8885                   goto unknown;
8886               }
8887
8888             case 'i':
8889               if (name[2] == 'n' &&
8890                   name[3] == 'd' &&
8891                   name[4] == 'e' &&
8892                   name[5] == 'x')
8893               {                                   /* rindex     */
8894                 return -KEY_rindex;
8895               }
8896
8897               goto unknown;
8898
8899             default:
8900               goto unknown;
8901           }
8902
8903         case 's':
8904           switch (name[1])
8905           {
8906             case 'c':
8907               if (name[2] == 'a' &&
8908                   name[3] == 'l' &&
8909                   name[4] == 'a' &&
8910                   name[5] == 'r')
8911               {                                   /* scalar     */
8912                 return KEY_scalar;
8913               }
8914
8915               goto unknown;
8916
8917             case 'e':
8918               switch (name[2])
8919               {
8920                 case 'l':
8921                   if (name[3] == 'e' &&
8922                       name[4] == 'c' &&
8923                       name[5] == 't')
8924                   {                               /* select     */
8925                     return -KEY_select;
8926                   }
8927
8928                   goto unknown;
8929
8930                 case 'm':
8931                   switch (name[3])
8932                   {
8933                     case 'c':
8934                       if (name[4] == 't' &&
8935                           name[5] == 'l')
8936                       {                           /* semctl     */
8937                         return -KEY_semctl;
8938                       }
8939
8940                       goto unknown;
8941
8942                     case 'g':
8943                       if (name[4] == 'e' &&
8944                           name[5] == 't')
8945                       {                           /* semget     */
8946                         return -KEY_semget;
8947                       }
8948
8949                       goto unknown;
8950
8951                     default:
8952                       goto unknown;
8953                   }
8954
8955                 default:
8956                   goto unknown;
8957               }
8958
8959             case 'h':
8960               if (name[2] == 'm')
8961               {
8962                 switch (name[3])
8963                 {
8964                   case 'c':
8965                     if (name[4] == 't' &&
8966                         name[5] == 'l')
8967                     {                             /* shmctl     */
8968                       return -KEY_shmctl;
8969                     }
8970
8971                     goto unknown;
8972
8973                   case 'g':
8974                     if (name[4] == 'e' &&
8975                         name[5] == 't')
8976                     {                             /* shmget     */
8977                       return -KEY_shmget;
8978                     }
8979
8980                     goto unknown;
8981
8982                   default:
8983                     goto unknown;
8984                 }
8985               }
8986
8987               goto unknown;
8988
8989             case 'o':
8990               if (name[2] == 'c' &&
8991                   name[3] == 'k' &&
8992                   name[4] == 'e' &&
8993                   name[5] == 't')
8994               {                                   /* socket     */
8995                 return -KEY_socket;
8996               }
8997
8998               goto unknown;
8999
9000             case 'p':
9001               if (name[2] == 'l' &&
9002                   name[3] == 'i' &&
9003                   name[4] == 'c' &&
9004                   name[5] == 'e')
9005               {                                   /* splice     */
9006                 return -KEY_splice;
9007               }
9008
9009               goto unknown;
9010
9011             case 'u':
9012               if (name[2] == 'b' &&
9013                   name[3] == 's' &&
9014                   name[4] == 't' &&
9015                   name[5] == 'r')
9016               {                                   /* substr     */
9017                 return -KEY_substr;
9018               }
9019
9020               goto unknown;
9021
9022             case 'y':
9023               if (name[2] == 's' &&
9024                   name[3] == 't' &&
9025                   name[4] == 'e' &&
9026                   name[5] == 'm')
9027               {                                   /* system     */
9028                 return -KEY_system;
9029               }
9030
9031               goto unknown;
9032
9033             default:
9034               goto unknown;
9035           }
9036
9037         case 'u':
9038           if (name[1] == 'n')
9039           {
9040             switch (name[2])
9041             {
9042               case 'l':
9043                 switch (name[3])
9044                 {
9045                   case 'e':
9046                     if (name[4] == 's' &&
9047                         name[5] == 's')
9048                     {                             /* unless     */
9049                       return KEY_unless;
9050                     }
9051
9052                     goto unknown;
9053
9054                   case 'i':
9055                     if (name[4] == 'n' &&
9056                         name[5] == 'k')
9057                     {                             /* unlink     */
9058                       return -KEY_unlink;
9059                     }
9060
9061                     goto unknown;
9062
9063                   default:
9064                     goto unknown;
9065                 }
9066
9067               case 'p':
9068                 if (name[3] == 'a' &&
9069                     name[4] == 'c' &&
9070                     name[5] == 'k')
9071                 {                                 /* unpack     */
9072                   return -KEY_unpack;
9073                 }
9074
9075                 goto unknown;
9076
9077               default:
9078                 goto unknown;
9079             }
9080           }
9081
9082           goto unknown;
9083
9084         case 'v':
9085           if (name[1] == 'a' &&
9086               name[2] == 'l' &&
9087               name[3] == 'u' &&
9088               name[4] == 'e' &&
9089               name[5] == 's')
9090           {                                       /* values     */
9091             return -KEY_values;
9092           }
9093
9094           goto unknown;
9095
9096         default:
9097           goto unknown;
9098       }
9099
9100     case 7: /* 29 tokens of length 7 */
9101       switch (name[0])
9102       {
9103         case 'D':
9104           if (name[1] == 'E' &&
9105               name[2] == 'S' &&
9106               name[3] == 'T' &&
9107               name[4] == 'R' &&
9108               name[5] == 'O' &&
9109               name[6] == 'Y')
9110           {                                       /* DESTROY    */
9111             return KEY_DESTROY;
9112           }
9113
9114           goto unknown;
9115
9116         case '_':
9117           if (name[1] == '_' &&
9118               name[2] == 'E' &&
9119               name[3] == 'N' &&
9120               name[4] == 'D' &&
9121               name[5] == '_' &&
9122               name[6] == '_')
9123           {                                       /* __END__    */
9124             return KEY___END__;
9125           }
9126
9127           goto unknown;
9128
9129         case 'b':
9130           if (name[1] == 'i' &&
9131               name[2] == 'n' &&
9132               name[3] == 'm' &&
9133               name[4] == 'o' &&
9134               name[5] == 'd' &&
9135               name[6] == 'e')
9136           {                                       /* binmode    */
9137             return -KEY_binmode;
9138           }
9139
9140           goto unknown;
9141
9142         case 'c':
9143           if (name[1] == 'o' &&
9144               name[2] == 'n' &&
9145               name[3] == 'n' &&
9146               name[4] == 'e' &&
9147               name[5] == 'c' &&
9148               name[6] == 't')
9149           {                                       /* connect    */
9150             return -KEY_connect;
9151           }
9152
9153           goto unknown;
9154
9155         case 'd':
9156           switch (name[1])
9157           {
9158             case 'b':
9159               if (name[2] == 'm' &&
9160                   name[3] == 'o' &&
9161                   name[4] == 'p' &&
9162                   name[5] == 'e' &&
9163                   name[6] == 'n')
9164               {                                   /* dbmopen    */
9165                 return -KEY_dbmopen;
9166               }
9167
9168               goto unknown;
9169
9170             case 'e':
9171               if (name[2] == 'f')
9172               {
9173                 switch (name[3])
9174                 {
9175                   case 'a':
9176                     if (name[4] == 'u' &&
9177                         name[5] == 'l' &&
9178                         name[6] == 't')
9179                     {                             /* default    */
9180                       return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9181                     }
9182
9183                     goto unknown;
9184
9185                   case 'i':
9186                     if (name[4] == 'n' &&
9187                         name[5] == 'e' &&
9188                         name[6] == 'd')
9189                     {                             /* defined    */
9190                       return KEY_defined;
9191                     }
9192
9193                     goto unknown;
9194
9195                   default:
9196                     goto unknown;
9197                 }
9198               }
9199
9200               goto unknown;
9201
9202             default:
9203               goto unknown;
9204           }
9205
9206         case 'f':
9207           if (name[1] == 'o' &&
9208               name[2] == 'r' &&
9209               name[3] == 'e' &&
9210               name[4] == 'a' &&
9211               name[5] == 'c' &&
9212               name[6] == 'h')
9213           {                                       /* foreach    */
9214             return KEY_foreach;
9215           }
9216
9217           goto unknown;
9218
9219         case 'g':
9220           if (name[1] == 'e' &&
9221               name[2] == 't' &&
9222               name[3] == 'p')
9223           {
9224             switch (name[4])
9225             {
9226               case 'g':
9227                 if (name[5] == 'r' &&
9228                     name[6] == 'p')
9229                 {                                 /* getpgrp    */
9230                   return -KEY_getpgrp;
9231                 }
9232
9233                 goto unknown;
9234
9235               case 'p':
9236                 if (name[5] == 'i' &&
9237                     name[6] == 'd')
9238                 {                                 /* getppid    */
9239                   return -KEY_getppid;
9240                 }
9241
9242                 goto unknown;
9243
9244               default:
9245                 goto unknown;
9246             }
9247           }
9248
9249           goto unknown;
9250
9251         case 'l':
9252           if (name[1] == 'c' &&
9253               name[2] == 'f' &&
9254               name[3] == 'i' &&
9255               name[4] == 'r' &&
9256               name[5] == 's' &&
9257               name[6] == 't')
9258           {                                       /* lcfirst    */
9259             return -KEY_lcfirst;
9260           }
9261
9262           goto unknown;
9263
9264         case 'o':
9265           if (name[1] == 'p' &&
9266               name[2] == 'e' &&
9267               name[3] == 'n' &&
9268               name[4] == 'd' &&
9269               name[5] == 'i' &&
9270               name[6] == 'r')
9271           {                                       /* opendir    */
9272             return -KEY_opendir;
9273           }
9274
9275           goto unknown;
9276
9277         case 'p':
9278           if (name[1] == 'a' &&
9279               name[2] == 'c' &&
9280               name[3] == 'k' &&
9281               name[4] == 'a' &&
9282               name[5] == 'g' &&
9283               name[6] == 'e')
9284           {                                       /* package    */
9285             return KEY_package;
9286           }
9287
9288           goto unknown;
9289
9290         case 'r':
9291           if (name[1] == 'e')
9292           {
9293             switch (name[2])
9294             {
9295               case 'a':
9296                 if (name[3] == 'd' &&
9297                     name[4] == 'd' &&
9298                     name[5] == 'i' &&
9299                     name[6] == 'r')
9300                 {                                 /* readdir    */
9301                   return -KEY_readdir;
9302                 }
9303
9304                 goto unknown;
9305
9306               case 'q':
9307                 if (name[3] == 'u' &&
9308                     name[4] == 'i' &&
9309                     name[5] == 'r' &&
9310                     name[6] == 'e')
9311                 {                                 /* require    */
9312                   return KEY_require;
9313                 }
9314
9315                 goto unknown;
9316
9317               case 'v':
9318                 if (name[3] == 'e' &&
9319                     name[4] == 'r' &&
9320                     name[5] == 's' &&
9321                     name[6] == 'e')
9322                 {                                 /* reverse    */
9323                   return -KEY_reverse;
9324                 }
9325
9326                 goto unknown;
9327
9328               default:
9329                 goto unknown;
9330             }
9331           }
9332
9333           goto unknown;
9334
9335         case 's':
9336           switch (name[1])
9337           {
9338             case 'e':
9339               switch (name[2])
9340               {
9341                 case 'e':
9342                   if (name[3] == 'k' &&
9343                       name[4] == 'd' &&
9344                       name[5] == 'i' &&
9345                       name[6] == 'r')
9346                   {                               /* seekdir    */
9347                     return -KEY_seekdir;
9348                   }
9349
9350                   goto unknown;
9351
9352                 case 't':
9353                   if (name[3] == 'p' &&
9354                       name[4] == 'g' &&
9355                       name[5] == 'r' &&
9356                       name[6] == 'p')
9357                   {                               /* setpgrp    */
9358                     return -KEY_setpgrp;
9359                   }
9360
9361                   goto unknown;
9362
9363                 default:
9364                   goto unknown;
9365               }
9366
9367             case 'h':
9368               if (name[2] == 'm' &&
9369                   name[3] == 'r' &&
9370                   name[4] == 'e' &&
9371                   name[5] == 'a' &&
9372                   name[6] == 'd')
9373               {                                   /* shmread    */
9374                 return -KEY_shmread;
9375               }
9376
9377               goto unknown;
9378
9379             case 'p':
9380               if (name[2] == 'r' &&
9381                   name[3] == 'i' &&
9382                   name[4] == 'n' &&
9383                   name[5] == 't' &&
9384                   name[6] == 'f')
9385               {                                   /* sprintf    */
9386                 return -KEY_sprintf;
9387               }
9388
9389               goto unknown;
9390
9391             case 'y':
9392               switch (name[2])
9393               {
9394                 case 'm':
9395                   if (name[3] == 'l' &&
9396                       name[4] == 'i' &&
9397                       name[5] == 'n' &&
9398                       name[6] == 'k')
9399                   {                               /* symlink    */
9400                     return -KEY_symlink;
9401                   }
9402
9403                   goto unknown;
9404
9405                 case 's':
9406                   switch (name[3])
9407                   {
9408                     case 'c':
9409                       if (name[4] == 'a' &&
9410                           name[5] == 'l' &&
9411                           name[6] == 'l')
9412                       {                           /* syscall    */
9413                         return -KEY_syscall;
9414                       }
9415
9416                       goto unknown;
9417
9418                     case 'o':
9419                       if (name[4] == 'p' &&
9420                           name[5] == 'e' &&
9421                           name[6] == 'n')
9422                       {                           /* sysopen    */
9423                         return -KEY_sysopen;
9424                       }
9425
9426                       goto unknown;
9427
9428                     case 'r':
9429                       if (name[4] == 'e' &&
9430                           name[5] == 'a' &&
9431                           name[6] == 'd')
9432                       {                           /* sysread    */
9433                         return -KEY_sysread;
9434                       }
9435
9436                       goto unknown;
9437
9438                     case 's':
9439                       if (name[4] == 'e' &&
9440                           name[5] == 'e' &&
9441                           name[6] == 'k')
9442                       {                           /* sysseek    */
9443                         return -KEY_sysseek;
9444                       }
9445
9446                       goto unknown;
9447
9448                     default:
9449                       goto unknown;
9450                   }
9451
9452                 default:
9453                   goto unknown;
9454               }
9455
9456             default:
9457               goto unknown;
9458           }
9459
9460         case 't':
9461           if (name[1] == 'e' &&
9462               name[2] == 'l' &&
9463               name[3] == 'l' &&
9464               name[4] == 'd' &&
9465               name[5] == 'i' &&
9466               name[6] == 'r')
9467           {                                       /* telldir    */
9468             return -KEY_telldir;
9469           }
9470
9471           goto unknown;
9472
9473         case 'u':
9474           switch (name[1])
9475           {
9476             case 'c':
9477               if (name[2] == 'f' &&
9478                   name[3] == 'i' &&
9479                   name[4] == 'r' &&
9480                   name[5] == 's' &&
9481                   name[6] == 't')
9482               {                                   /* ucfirst    */
9483                 return -KEY_ucfirst;
9484               }
9485
9486               goto unknown;
9487
9488             case 'n':
9489               if (name[2] == 's' &&
9490                   name[3] == 'h' &&
9491                   name[4] == 'i' &&
9492                   name[5] == 'f' &&
9493                   name[6] == 't')
9494               {                                   /* unshift    */
9495                 return -KEY_unshift;
9496               }
9497
9498               goto unknown;
9499
9500             default:
9501               goto unknown;
9502           }
9503
9504         case 'w':
9505           if (name[1] == 'a' &&
9506               name[2] == 'i' &&
9507               name[3] == 't' &&
9508               name[4] == 'p' &&
9509               name[5] == 'i' &&
9510               name[6] == 'd')
9511           {                                       /* waitpid    */
9512             return -KEY_waitpid;
9513           }
9514
9515           goto unknown;
9516
9517         default:
9518           goto unknown;
9519       }
9520
9521     case 8: /* 26 tokens of length 8 */
9522       switch (name[0])
9523       {
9524         case 'A':
9525           if (name[1] == 'U' &&
9526               name[2] == 'T' &&
9527               name[3] == 'O' &&
9528               name[4] == 'L' &&
9529               name[5] == 'O' &&
9530               name[6] == 'A' &&
9531               name[7] == 'D')
9532           {                                       /* AUTOLOAD   */
9533             return KEY_AUTOLOAD;
9534           }
9535
9536           goto unknown;
9537
9538         case '_':
9539           if (name[1] == '_')
9540           {
9541             switch (name[2])
9542             {
9543               case 'D':
9544                 if (name[3] == 'A' &&
9545                     name[4] == 'T' &&
9546                     name[5] == 'A' &&
9547                     name[6] == '_' &&
9548                     name[7] == '_')
9549                 {                                 /* __DATA__   */
9550                   return KEY___DATA__;
9551                 }
9552
9553                 goto unknown;
9554
9555               case 'F':
9556                 if (name[3] == 'I' &&
9557                     name[4] == 'L' &&
9558                     name[5] == 'E' &&
9559                     name[6] == '_' &&
9560                     name[7] == '_')
9561                 {                                 /* __FILE__   */
9562                   return -KEY___FILE__;
9563                 }
9564
9565                 goto unknown;
9566
9567               case 'L':
9568                 if (name[3] == 'I' &&
9569                     name[4] == 'N' &&
9570                     name[5] == 'E' &&
9571                     name[6] == '_' &&
9572                     name[7] == '_')
9573                 {                                 /* __LINE__   */
9574                   return -KEY___LINE__;
9575                 }
9576
9577                 goto unknown;
9578
9579               default:
9580                 goto unknown;
9581             }
9582           }
9583
9584           goto unknown;
9585
9586         case 'c':
9587           switch (name[1])
9588           {
9589             case 'l':
9590               if (name[2] == 'o' &&
9591                   name[3] == 's' &&
9592                   name[4] == 'e' &&
9593                   name[5] == 'd' &&
9594                   name[6] == 'i' &&
9595                   name[7] == 'r')
9596               {                                   /* closedir   */
9597                 return -KEY_closedir;
9598               }
9599
9600               goto unknown;
9601
9602             case 'o':
9603               if (name[2] == 'n' &&
9604                   name[3] == 't' &&
9605                   name[4] == 'i' &&
9606                   name[5] == 'n' &&
9607                   name[6] == 'u' &&
9608                   name[7] == 'e')
9609               {                                   /* continue   */
9610                 return -KEY_continue;
9611               }
9612
9613               goto unknown;
9614
9615             default:
9616               goto unknown;
9617           }
9618
9619         case 'd':
9620           if (name[1] == 'b' &&
9621               name[2] == 'm' &&
9622               name[3] == 'c' &&
9623               name[4] == 'l' &&
9624               name[5] == 'o' &&
9625               name[6] == 's' &&
9626               name[7] == 'e')
9627           {                                       /* dbmclose   */
9628             return -KEY_dbmclose;
9629           }
9630
9631           goto unknown;
9632
9633         case 'e':
9634           if (name[1] == 'n' &&
9635               name[2] == 'd')
9636           {
9637             switch (name[3])
9638             {
9639               case 'g':
9640                 if (name[4] == 'r' &&
9641                     name[5] == 'e' &&
9642                     name[6] == 'n' &&
9643                     name[7] == 't')
9644                 {                                 /* endgrent   */
9645                   return -KEY_endgrent;
9646                 }
9647
9648                 goto unknown;
9649
9650               case 'p':
9651                 if (name[4] == 'w' &&
9652                     name[5] == 'e' &&
9653                     name[6] == 'n' &&
9654                     name[7] == 't')
9655                 {                                 /* endpwent   */
9656                   return -KEY_endpwent;
9657                 }
9658
9659                 goto unknown;
9660
9661               default:
9662                 goto unknown;
9663             }
9664           }
9665
9666           goto unknown;
9667
9668         case 'f':
9669           if (name[1] == 'o' &&
9670               name[2] == 'r' &&
9671               name[3] == 'm' &&
9672               name[4] == 'l' &&
9673               name[5] == 'i' &&
9674               name[6] == 'n' &&
9675               name[7] == 'e')
9676           {                                       /* formline   */
9677             return -KEY_formline;
9678           }
9679
9680           goto unknown;
9681
9682         case 'g':
9683           if (name[1] == 'e' &&
9684               name[2] == 't')
9685           {
9686             switch (name[3])
9687             {
9688               case 'g':
9689                 if (name[4] == 'r')
9690                 {
9691                   switch (name[5])
9692                   {
9693                     case 'e':
9694                       if (name[6] == 'n' &&
9695                           name[7] == 't')
9696                       {                           /* getgrent   */
9697                         return -KEY_getgrent;
9698                       }
9699
9700                       goto unknown;
9701
9702                     case 'g':
9703                       if (name[6] == 'i' &&
9704                           name[7] == 'd')
9705                       {                           /* getgrgid   */
9706                         return -KEY_getgrgid;
9707                       }
9708
9709                       goto unknown;
9710
9711                     case 'n':
9712                       if (name[6] == 'a' &&
9713                           name[7] == 'm')
9714                       {                           /* getgrnam   */
9715                         return -KEY_getgrnam;
9716                       }
9717
9718                       goto unknown;
9719
9720                     default:
9721                       goto unknown;
9722                   }
9723                 }
9724
9725                 goto unknown;
9726
9727               case 'l':
9728                 if (name[4] == 'o' &&
9729                     name[5] == 'g' &&
9730                     name[6] == 'i' &&
9731                     name[7] == 'n')
9732                 {                                 /* getlogin   */
9733                   return -KEY_getlogin;
9734                 }
9735
9736                 goto unknown;
9737
9738               case 'p':
9739                 if (name[4] == 'w')
9740                 {
9741                   switch (name[5])
9742                   {
9743                     case 'e':
9744                       if (name[6] == 'n' &&
9745                           name[7] == 't')
9746                       {                           /* getpwent   */
9747                         return -KEY_getpwent;
9748                       }
9749
9750                       goto unknown;
9751
9752                     case 'n':
9753                       if (name[6] == 'a' &&
9754                           name[7] == 'm')
9755                       {                           /* getpwnam   */
9756                         return -KEY_getpwnam;
9757                       }
9758
9759                       goto unknown;
9760
9761                     case 'u':
9762                       if (name[6] == 'i' &&
9763                           name[7] == 'd')
9764                       {                           /* getpwuid   */
9765                         return -KEY_getpwuid;
9766                       }
9767
9768                       goto unknown;
9769
9770                     default:
9771                       goto unknown;
9772                   }
9773                 }
9774
9775                 goto unknown;
9776
9777               default:
9778                 goto unknown;
9779             }
9780           }
9781
9782           goto unknown;
9783
9784         case 'r':
9785           if (name[1] == 'e' &&
9786               name[2] == 'a' &&
9787               name[3] == 'd')
9788           {
9789             switch (name[4])
9790             {
9791               case 'l':
9792                 if (name[5] == 'i' &&
9793                     name[6] == 'n')
9794                 {
9795                   switch (name[7])
9796                   {
9797                     case 'e':
9798                       {                           /* readline   */
9799                         return -KEY_readline;
9800                       }
9801
9802                     case 'k':
9803                       {                           /* readlink   */
9804                         return -KEY_readlink;
9805                       }
9806
9807                     default:
9808                       goto unknown;
9809                   }
9810                 }
9811
9812                 goto unknown;
9813
9814               case 'p':
9815                 if (name[5] == 'i' &&
9816                     name[6] == 'p' &&
9817                     name[7] == 'e')
9818                 {                                 /* readpipe   */
9819                   return -KEY_readpipe;
9820                 }
9821
9822                 goto unknown;
9823
9824               default:
9825                 goto unknown;
9826             }
9827           }
9828
9829           goto unknown;
9830
9831         case 's':
9832           switch (name[1])
9833           {
9834             case 'e':
9835               if (name[2] == 't')
9836               {
9837                 switch (name[3])
9838                 {
9839                   case 'g':
9840                     if (name[4] == 'r' &&
9841                         name[5] == 'e' &&
9842                         name[6] == 'n' &&
9843                         name[7] == 't')
9844                     {                             /* setgrent   */
9845                       return -KEY_setgrent;
9846                     }
9847
9848                     goto unknown;
9849
9850                   case 'p':
9851                     if (name[4] == 'w' &&
9852                         name[5] == 'e' &&
9853                         name[6] == 'n' &&
9854                         name[7] == 't')
9855                     {                             /* setpwent   */
9856                       return -KEY_setpwent;
9857                     }
9858
9859                     goto unknown;
9860
9861                   default:
9862                     goto unknown;
9863                 }
9864               }
9865
9866               goto unknown;
9867
9868             case 'h':
9869               switch (name[2])
9870               {
9871                 case 'm':
9872                   if (name[3] == 'w' &&
9873                       name[4] == 'r' &&
9874                       name[5] == 'i' &&
9875                       name[6] == 't' &&
9876                       name[7] == 'e')
9877                   {                               /* shmwrite   */
9878                     return -KEY_shmwrite;
9879                   }
9880
9881                   goto unknown;
9882
9883                 case 'u':
9884                   if (name[3] == 't' &&
9885                       name[4] == 'd' &&
9886                       name[5] == 'o' &&
9887                       name[6] == 'w' &&
9888                       name[7] == 'n')
9889                   {                               /* shutdown   */
9890                     return -KEY_shutdown;
9891                   }
9892
9893                   goto unknown;
9894
9895                 default:
9896                   goto unknown;
9897               }
9898
9899             case 'y':
9900               if (name[2] == 's' &&
9901                   name[3] == 'w' &&
9902                   name[4] == 'r' &&
9903                   name[5] == 'i' &&
9904                   name[6] == 't' &&
9905                   name[7] == 'e')
9906               {                                   /* syswrite   */
9907                 return -KEY_syswrite;
9908               }
9909
9910               goto unknown;
9911
9912             default:
9913               goto unknown;
9914           }
9915
9916         case 't':
9917           if (name[1] == 'r' &&
9918               name[2] == 'u' &&
9919               name[3] == 'n' &&
9920               name[4] == 'c' &&
9921               name[5] == 'a' &&
9922               name[6] == 't' &&
9923               name[7] == 'e')
9924           {                                       /* truncate   */
9925             return -KEY_truncate;
9926           }
9927
9928           goto unknown;
9929
9930         default:
9931           goto unknown;
9932       }
9933
9934     case 9: /* 9 tokens of length 9 */
9935       switch (name[0])
9936       {
9937         case 'U':
9938           if (name[1] == 'N' &&
9939               name[2] == 'I' &&
9940               name[3] == 'T' &&
9941               name[4] == 'C' &&
9942               name[5] == 'H' &&
9943               name[6] == 'E' &&
9944               name[7] == 'C' &&
9945               name[8] == 'K')
9946           {                                       /* UNITCHECK  */
9947             return KEY_UNITCHECK;
9948           }
9949
9950           goto unknown;
9951
9952         case 'e':
9953           if (name[1] == 'n' &&
9954               name[2] == 'd' &&
9955               name[3] == 'n' &&
9956               name[4] == 'e' &&
9957               name[5] == 't' &&
9958               name[6] == 'e' &&
9959               name[7] == 'n' &&
9960               name[8] == 't')
9961           {                                       /* endnetent  */
9962             return -KEY_endnetent;
9963           }
9964
9965           goto unknown;
9966
9967         case 'g':
9968           if (name[1] == 'e' &&
9969               name[2] == 't' &&
9970               name[3] == 'n' &&
9971               name[4] == 'e' &&
9972               name[5] == 't' &&
9973               name[6] == 'e' &&
9974               name[7] == 'n' &&
9975               name[8] == 't')
9976           {                                       /* getnetent  */
9977             return -KEY_getnetent;
9978           }
9979
9980           goto unknown;
9981
9982         case 'l':
9983           if (name[1] == 'o' &&
9984               name[2] == 'c' &&
9985               name[3] == 'a' &&
9986               name[4] == 'l' &&
9987               name[5] == 't' &&
9988               name[6] == 'i' &&
9989               name[7] == 'm' &&
9990               name[8] == 'e')
9991           {                                       /* localtime  */
9992             return -KEY_localtime;
9993           }
9994
9995           goto unknown;
9996
9997         case 'p':
9998           if (name[1] == 'r' &&
9999               name[2] == 'o' &&
10000               name[3] == 't' &&
10001               name[4] == 'o' &&
10002               name[5] == 't' &&
10003               name[6] == 'y' &&
10004               name[7] == 'p' &&
10005               name[8] == 'e')
10006           {                                       /* prototype  */
10007             return KEY_prototype;
10008           }
10009
10010           goto unknown;
10011
10012         case 'q':
10013           if (name[1] == 'u' &&
10014               name[2] == 'o' &&
10015               name[3] == 't' &&
10016               name[4] == 'e' &&
10017               name[5] == 'm' &&
10018               name[6] == 'e' &&
10019               name[7] == 't' &&
10020               name[8] == 'a')
10021           {                                       /* quotemeta  */
10022             return -KEY_quotemeta;
10023           }
10024
10025           goto unknown;
10026
10027         case 'r':
10028           if (name[1] == 'e' &&
10029               name[2] == 'w' &&
10030               name[3] == 'i' &&
10031               name[4] == 'n' &&
10032               name[5] == 'd' &&
10033               name[6] == 'd' &&
10034               name[7] == 'i' &&
10035               name[8] == 'r')
10036           {                                       /* rewinddir  */
10037             return -KEY_rewinddir;
10038           }
10039
10040           goto unknown;
10041
10042         case 's':
10043           if (name[1] == 'e' &&
10044               name[2] == 't' &&
10045               name[3] == 'n' &&
10046               name[4] == 'e' &&
10047               name[5] == 't' &&
10048               name[6] == 'e' &&
10049               name[7] == 'n' &&
10050               name[8] == 't')
10051           {                                       /* setnetent  */
10052             return -KEY_setnetent;
10053           }
10054
10055           goto unknown;
10056
10057         case 'w':
10058           if (name[1] == 'a' &&
10059               name[2] == 'n' &&
10060               name[3] == 't' &&
10061               name[4] == 'a' &&
10062               name[5] == 'r' &&
10063               name[6] == 'r' &&
10064               name[7] == 'a' &&
10065               name[8] == 'y')
10066           {                                       /* wantarray  */
10067             return -KEY_wantarray;
10068           }
10069
10070           goto unknown;
10071
10072         default:
10073           goto unknown;
10074       }
10075
10076     case 10: /* 9 tokens of length 10 */
10077       switch (name[0])
10078       {
10079         case 'e':
10080           if (name[1] == 'n' &&
10081               name[2] == 'd')
10082           {
10083             switch (name[3])
10084             {
10085               case 'h':
10086                 if (name[4] == 'o' &&
10087                     name[5] == 's' &&
10088                     name[6] == 't' &&
10089                     name[7] == 'e' &&
10090                     name[8] == 'n' &&
10091                     name[9] == 't')
10092                 {                                 /* endhostent */
10093                   return -KEY_endhostent;
10094                 }
10095
10096                 goto unknown;
10097
10098               case 's':
10099                 if (name[4] == 'e' &&
10100                     name[5] == 'r' &&
10101                     name[6] == 'v' &&
10102                     name[7] == 'e' &&
10103                     name[8] == 'n' &&
10104                     name[9] == 't')
10105                 {                                 /* endservent */
10106                   return -KEY_endservent;
10107                 }
10108
10109                 goto unknown;
10110
10111               default:
10112                 goto unknown;
10113             }
10114           }
10115
10116           goto unknown;
10117
10118         case 'g':
10119           if (name[1] == 'e' &&
10120               name[2] == 't')
10121           {
10122             switch (name[3])
10123             {
10124               case 'h':
10125                 if (name[4] == 'o' &&
10126                     name[5] == 's' &&
10127                     name[6] == 't' &&
10128                     name[7] == 'e' &&
10129                     name[8] == 'n' &&
10130                     name[9] == 't')
10131                 {                                 /* gethostent */
10132                   return -KEY_gethostent;
10133                 }
10134
10135                 goto unknown;
10136
10137               case 's':
10138                 switch (name[4])
10139                 {
10140                   case 'e':
10141                     if (name[5] == 'r' &&
10142                         name[6] == 'v' &&
10143                         name[7] == 'e' &&
10144                         name[8] == 'n' &&
10145                         name[9] == 't')
10146                     {                             /* getservent */
10147                       return -KEY_getservent;
10148                     }
10149
10150                     goto unknown;
10151
10152                   case 'o':
10153                     if (name[5] == 'c' &&
10154                         name[6] == 'k' &&
10155                         name[7] == 'o' &&
10156                         name[8] == 'p' &&
10157                         name[9] == 't')
10158                     {                             /* getsockopt */
10159                       return -KEY_getsockopt;
10160                     }
10161
10162                     goto unknown;
10163
10164                   default:
10165                     goto unknown;
10166                 }
10167
10168               default:
10169                 goto unknown;
10170             }
10171           }
10172
10173           goto unknown;
10174
10175         case 's':
10176           switch (name[1])
10177           {
10178             case 'e':
10179               if (name[2] == 't')
10180               {
10181                 switch (name[3])
10182                 {
10183                   case 'h':
10184                     if (name[4] == 'o' &&
10185                         name[5] == 's' &&
10186                         name[6] == 't' &&
10187                         name[7] == 'e' &&
10188                         name[8] == 'n' &&
10189                         name[9] == 't')
10190                     {                             /* sethostent */
10191                       return -KEY_sethostent;
10192                     }
10193
10194                     goto unknown;
10195
10196                   case 's':
10197                     switch (name[4])
10198                     {
10199                       case 'e':
10200                         if (name[5] == 'r' &&
10201                             name[6] == 'v' &&
10202                             name[7] == 'e' &&
10203                             name[8] == 'n' &&
10204                             name[9] == 't')
10205                         {                         /* setservent */
10206                           return -KEY_setservent;
10207                         }
10208
10209                         goto unknown;
10210
10211                       case 'o':
10212                         if (name[5] == 'c' &&
10213                             name[6] == 'k' &&
10214                             name[7] == 'o' &&
10215                             name[8] == 'p' &&
10216                             name[9] == 't')
10217                         {                         /* setsockopt */
10218                           return -KEY_setsockopt;
10219                         }
10220
10221                         goto unknown;
10222
10223                       default:
10224                         goto unknown;
10225                     }
10226
10227                   default:
10228                     goto unknown;
10229                 }
10230               }
10231
10232               goto unknown;
10233
10234             case 'o':
10235               if (name[2] == 'c' &&
10236                   name[3] == 'k' &&
10237                   name[4] == 'e' &&
10238                   name[5] == 't' &&
10239                   name[6] == 'p' &&
10240                   name[7] == 'a' &&
10241                   name[8] == 'i' &&
10242                   name[9] == 'r')
10243               {                                   /* socketpair */
10244                 return -KEY_socketpair;
10245               }
10246
10247               goto unknown;
10248
10249             default:
10250               goto unknown;
10251           }
10252
10253         default:
10254           goto unknown;
10255       }
10256
10257     case 11: /* 8 tokens of length 11 */
10258       switch (name[0])
10259       {
10260         case '_':
10261           if (name[1] == '_' &&
10262               name[2] == 'P' &&
10263               name[3] == 'A' &&
10264               name[4] == 'C' &&
10265               name[5] == 'K' &&
10266               name[6] == 'A' &&
10267               name[7] == 'G' &&
10268               name[8] == 'E' &&
10269               name[9] == '_' &&
10270               name[10] == '_')
10271           {                                       /* __PACKAGE__ */
10272             return -KEY___PACKAGE__;
10273           }
10274
10275           goto unknown;
10276
10277         case 'e':
10278           if (name[1] == 'n' &&
10279               name[2] == 'd' &&
10280               name[3] == 'p' &&
10281               name[4] == 'r' &&
10282               name[5] == 'o' &&
10283               name[6] == 't' &&
10284               name[7] == 'o' &&
10285               name[8] == 'e' &&
10286               name[9] == 'n' &&
10287               name[10] == 't')
10288           {                                       /* endprotoent */
10289             return -KEY_endprotoent;
10290           }
10291
10292           goto unknown;
10293
10294         case 'g':
10295           if (name[1] == 'e' &&
10296               name[2] == 't')
10297           {
10298             switch (name[3])
10299             {
10300               case 'p':
10301                 switch (name[4])
10302                 {
10303                   case 'e':
10304                     if (name[5] == 'e' &&
10305                         name[6] == 'r' &&
10306                         name[7] == 'n' &&
10307                         name[8] == 'a' &&
10308                         name[9] == 'm' &&
10309                         name[10] == 'e')
10310                     {                             /* getpeername */
10311                       return -KEY_getpeername;
10312                     }
10313
10314                     goto unknown;
10315
10316                   case 'r':
10317                     switch (name[5])
10318                     {
10319                       case 'i':
10320                         if (name[6] == 'o' &&
10321                             name[7] == 'r' &&
10322                             name[8] == 'i' &&
10323                             name[9] == 't' &&
10324                             name[10] == 'y')
10325                         {                         /* getpriority */
10326                           return -KEY_getpriority;
10327                         }
10328
10329                         goto unknown;
10330
10331                       case 'o':
10332                         if (name[6] == 't' &&
10333                             name[7] == 'o' &&
10334                             name[8] == 'e' &&
10335                             name[9] == 'n' &&
10336                             name[10] == 't')
10337                         {                         /* getprotoent */
10338                           return -KEY_getprotoent;
10339                         }
10340
10341                         goto unknown;
10342
10343                       default:
10344                         goto unknown;
10345                     }
10346
10347                   default:
10348                     goto unknown;
10349                 }
10350
10351               case 's':
10352                 if (name[4] == 'o' &&
10353                     name[5] == 'c' &&
10354                     name[6] == 'k' &&
10355                     name[7] == 'n' &&
10356                     name[8] == 'a' &&
10357                     name[9] == 'm' &&
10358                     name[10] == 'e')
10359                 {                                 /* getsockname */
10360                   return -KEY_getsockname;
10361                 }
10362
10363                 goto unknown;
10364
10365               default:
10366                 goto unknown;
10367             }
10368           }
10369
10370           goto unknown;
10371
10372         case 's':
10373           if (name[1] == 'e' &&
10374               name[2] == 't' &&
10375               name[3] == 'p' &&
10376               name[4] == 'r')
10377           {
10378             switch (name[5])
10379             {
10380               case 'i':
10381                 if (name[6] == 'o' &&
10382                     name[7] == 'r' &&
10383                     name[8] == 'i' &&
10384                     name[9] == 't' &&
10385                     name[10] == 'y')
10386                 {                                 /* setpriority */
10387                   return -KEY_setpriority;
10388                 }
10389
10390                 goto unknown;
10391
10392               case 'o':
10393                 if (name[6] == 't' &&
10394                     name[7] == 'o' &&
10395                     name[8] == 'e' &&
10396                     name[9] == 'n' &&
10397                     name[10] == 't')
10398                 {                                 /* setprotoent */
10399                   return -KEY_setprotoent;
10400                 }
10401
10402                 goto unknown;
10403
10404               default:
10405                 goto unknown;
10406             }
10407           }
10408
10409           goto unknown;
10410
10411         default:
10412           goto unknown;
10413       }
10414
10415     case 12: /* 2 tokens of length 12 */
10416       if (name[0] == 'g' &&
10417           name[1] == 'e' &&
10418           name[2] == 't' &&
10419           name[3] == 'n' &&
10420           name[4] == 'e' &&
10421           name[5] == 't' &&
10422           name[6] == 'b' &&
10423           name[7] == 'y')
10424       {
10425         switch (name[8])
10426         {
10427           case 'a':
10428             if (name[9] == 'd' &&
10429                 name[10] == 'd' &&
10430                 name[11] == 'r')
10431             {                                     /* getnetbyaddr */
10432               return -KEY_getnetbyaddr;
10433             }
10434
10435             goto unknown;
10436
10437           case 'n':
10438             if (name[9] == 'a' &&
10439                 name[10] == 'm' &&
10440                 name[11] == 'e')
10441             {                                     /* getnetbyname */
10442               return -KEY_getnetbyname;
10443             }
10444
10445             goto unknown;
10446
10447           default:
10448             goto unknown;
10449         }
10450       }
10451
10452       goto unknown;
10453
10454     case 13: /* 4 tokens of length 13 */
10455       if (name[0] == 'g' &&
10456           name[1] == 'e' &&
10457           name[2] == 't')
10458       {
10459         switch (name[3])
10460         {
10461           case 'h':
10462             if (name[4] == 'o' &&
10463                 name[5] == 's' &&
10464                 name[6] == 't' &&
10465                 name[7] == 'b' &&
10466                 name[8] == 'y')
10467             {
10468               switch (name[9])
10469               {
10470                 case 'a':
10471                   if (name[10] == 'd' &&
10472                       name[11] == 'd' &&
10473                       name[12] == 'r')
10474                   {                               /* gethostbyaddr */
10475                     return -KEY_gethostbyaddr;
10476                   }
10477
10478                   goto unknown;
10479
10480                 case 'n':
10481                   if (name[10] == 'a' &&
10482                       name[11] == 'm' &&
10483                       name[12] == 'e')
10484                   {                               /* gethostbyname */
10485                     return -KEY_gethostbyname;
10486                   }
10487
10488                   goto unknown;
10489
10490                 default:
10491                   goto unknown;
10492               }
10493             }
10494
10495             goto unknown;
10496
10497           case 's':
10498             if (name[4] == 'e' &&
10499                 name[5] == 'r' &&
10500                 name[6] == 'v' &&
10501                 name[7] == 'b' &&
10502                 name[8] == 'y')
10503             {
10504               switch (name[9])
10505               {
10506                 case 'n':
10507                   if (name[10] == 'a' &&
10508                       name[11] == 'm' &&
10509                       name[12] == 'e')
10510                   {                               /* getservbyname */
10511                     return -KEY_getservbyname;
10512                   }
10513
10514                   goto unknown;
10515
10516                 case 'p':
10517                   if (name[10] == 'o' &&
10518                       name[11] == 'r' &&
10519                       name[12] == 't')
10520                   {                               /* getservbyport */
10521                     return -KEY_getservbyport;
10522                   }
10523
10524                   goto unknown;
10525
10526                 default:
10527                   goto unknown;
10528               }
10529             }
10530
10531             goto unknown;
10532
10533           default:
10534             goto unknown;
10535         }
10536       }
10537
10538       goto unknown;
10539
10540     case 14: /* 1 tokens of length 14 */
10541       if (name[0] == 'g' &&
10542           name[1] == 'e' &&
10543           name[2] == 't' &&
10544           name[3] == 'p' &&
10545           name[4] == 'r' &&
10546           name[5] == 'o' &&
10547           name[6] == 't' &&
10548           name[7] == 'o' &&
10549           name[8] == 'b' &&
10550           name[9] == 'y' &&
10551           name[10] == 'n' &&
10552           name[11] == 'a' &&
10553           name[12] == 'm' &&
10554           name[13] == 'e')
10555       {                                           /* getprotobyname */
10556         return -KEY_getprotobyname;
10557       }
10558
10559       goto unknown;
10560
10561     case 16: /* 1 tokens of length 16 */
10562       if (name[0] == 'g' &&
10563           name[1] == 'e' &&
10564           name[2] == 't' &&
10565           name[3] == 'p' &&
10566           name[4] == 'r' &&
10567           name[5] == 'o' &&
10568           name[6] == 't' &&
10569           name[7] == 'o' &&
10570           name[8] == 'b' &&
10571           name[9] == 'y' &&
10572           name[10] == 'n' &&
10573           name[11] == 'u' &&
10574           name[12] == 'm' &&
10575           name[13] == 'b' &&
10576           name[14] == 'e' &&
10577           name[15] == 'r')
10578       {                                           /* getprotobynumber */
10579         return -KEY_getprotobynumber;
10580       }
10581
10582       goto unknown;
10583
10584     default:
10585       goto unknown;
10586   }
10587
10588 unknown:
10589   return 0;
10590 }
10591
10592 STATIC void
10593 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10594 {
10595     dVAR;
10596
10597     PERL_ARGS_ASSERT_CHECKCOMMA;
10598
10599     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10600         if (ckWARN(WARN_SYNTAX)) {
10601             int level = 1;
10602             const char *w;
10603             for (w = s+2; *w && level; w++) {
10604                 if (*w == '(')
10605                     ++level;
10606                 else if (*w == ')')
10607                     --level;
10608             }
10609             while (isSPACE(*w))
10610                 ++w;
10611             /* the list of chars below is for end of statements or
10612              * block / parens, boolean operators (&&, ||, //) and branch
10613              * constructs (or, and, if, until, unless, while, err, for).
10614              * Not a very solid hack... */
10615             if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10616                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10617                             "%s (...) interpreted as function",name);
10618         }
10619     }
10620     while (s < PL_bufend && isSPACE(*s))
10621         s++;
10622     if (*s == '(')
10623         s++;
10624     while (s < PL_bufend && isSPACE(*s))
10625         s++;
10626     if (isIDFIRST_lazy_if(s,UTF)) {
10627         const char * const w = s++;
10628         while (isALNUM_lazy_if(s,UTF))
10629             s++;
10630         while (s < PL_bufend && isSPACE(*s))
10631             s++;
10632         if (*s == ',') {
10633             GV* gv;
10634             if (keyword(w, s - w, 0))
10635                 return;
10636
10637             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10638             if (gv && GvCVu(gv))
10639                 return;
10640             Perl_croak(aTHX_ "No comma allowed after %s", what);
10641         }
10642     }
10643 }
10644
10645 /* Either returns sv, or mortalizes sv and returns a new SV*.
10646    Best used as sv=new_constant(..., sv, ...).
10647    If s, pv are NULL, calls subroutine with one argument,
10648    and type is used with error messages only. */
10649
10650 STATIC SV *
10651 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10652                SV *sv, SV *pv, const char *type, STRLEN typelen)
10653 {
10654     dVAR; dSP;
10655     HV * const table = GvHV(PL_hintgv);          /* ^H */
10656     SV *res;
10657     SV **cvp;
10658     SV *cv, *typesv;
10659     const char *why1 = "", *why2 = "", *why3 = "";
10660
10661     PERL_ARGS_ASSERT_NEW_CONSTANT;
10662
10663     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10664         SV *msg;
10665
10666         why2 = (const char *)
10667             (strEQ(key,"charnames")
10668              ? "(possibly a missing \"use charnames ...\")"
10669              : "");
10670         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10671                             (type ? type: "undef"), why2);
10672
10673         /* This is convoluted and evil ("goto considered harmful")
10674          * but I do not understand the intricacies of all the different
10675          * failure modes of %^H in here.  The goal here is to make
10676          * the most probable error message user-friendly. --jhi */
10677
10678         goto msgdone;
10679
10680     report:
10681         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10682                             (type ? type: "undef"), why1, why2, why3);
10683     msgdone:
10684         yyerror(SvPVX_const(msg));
10685         SvREFCNT_dec(msg);
10686         return sv;
10687     }
10688     cvp = hv_fetch(table, key, keylen, FALSE);
10689     if (!cvp || !SvOK(*cvp)) {
10690         why1 = "$^H{";
10691         why2 = key;
10692         why3 = "} is not defined";
10693         goto report;
10694     }
10695     sv_2mortal(sv);                     /* Parent created it permanently */
10696     cv = *cvp;
10697     if (!pv && s)
10698         pv = newSVpvn_flags(s, len, SVs_TEMP);
10699     if (type && pv)
10700         typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10701     else
10702         typesv = &PL_sv_undef;
10703
10704     PUSHSTACKi(PERLSI_OVERLOAD);
10705     ENTER ;
10706     SAVETMPS;
10707
10708     PUSHMARK(SP) ;
10709     EXTEND(sp, 3);
10710     if (pv)
10711         PUSHs(pv);
10712     PUSHs(sv);
10713     if (pv)
10714         PUSHs(typesv);
10715     PUTBACK;
10716     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10717
10718     SPAGAIN ;
10719
10720     /* Check the eval first */
10721     if (!PL_in_eval && SvTRUE(ERRSV)) {
10722         sv_catpvs(ERRSV, "Propagated");
10723         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10724         (void)POPs;
10725         res = SvREFCNT_inc_simple(sv);
10726     }
10727     else {
10728         res = POPs;
10729         SvREFCNT_inc_simple_void(res);
10730     }
10731
10732     PUTBACK ;
10733     FREETMPS ;
10734     LEAVE ;
10735     POPSTACK;
10736
10737     if (!SvOK(res)) {
10738         why1 = "Call to &{$^H{";
10739         why2 = key;
10740         why3 = "}} did not return a defined value";
10741         sv = res;
10742         goto report;
10743     }
10744
10745     return res;
10746 }
10747
10748 /* Returns a NUL terminated string, with the length of the string written to
10749    *slp
10750    */
10751 STATIC char *
10752 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10753 {
10754     dVAR;
10755     register char *d = dest;
10756     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10757
10758     PERL_ARGS_ASSERT_SCAN_WORD;
10759
10760     for (;;) {
10761         if (d >= e)
10762             Perl_croak(aTHX_ ident_too_long);
10763         if (isALNUM(*s))        /* UTF handled below */
10764             *d++ = *s++;
10765         else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10766             *d++ = ':';
10767             *d++ = ':';
10768             s++;
10769         }
10770         else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10771             *d++ = *s++;
10772             *d++ = *s++;
10773         }
10774         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10775             char *t = s + UTF8SKIP(s);
10776             size_t len;
10777             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10778                 t += UTF8SKIP(t);
10779             len = t - s;
10780             if (d + len > e)
10781                 Perl_croak(aTHX_ ident_too_long);
10782             Copy(s, d, len, char);
10783             d += len;
10784             s = t;
10785         }
10786         else {
10787             *d = '\0';
10788             *slp = d - dest;
10789             return s;
10790         }
10791     }
10792 }
10793
10794 STATIC char *
10795 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10796 {
10797     dVAR;
10798     char *bracket = NULL;
10799     char funny = *s++;
10800     register char *d = dest;
10801     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10802
10803     PERL_ARGS_ASSERT_SCAN_IDENT;
10804
10805     if (isSPACE(*s))
10806         s = PEEKSPACE(s);
10807     if (isDIGIT(*s)) {
10808         while (isDIGIT(*s)) {
10809             if (d >= e)
10810                 Perl_croak(aTHX_ ident_too_long);
10811             *d++ = *s++;
10812         }
10813     }
10814     else {
10815         for (;;) {
10816             if (d >= e)
10817                 Perl_croak(aTHX_ ident_too_long);
10818             if (isALNUM(*s))    /* UTF handled below */
10819                 *d++ = *s++;
10820             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10821                 *d++ = ':';
10822                 *d++ = ':';
10823                 s++;
10824             }
10825             else if (*s == ':' && s[1] == ':') {
10826                 *d++ = *s++;
10827                 *d++ = *s++;
10828             }
10829             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10830                 char *t = s + UTF8SKIP(s);
10831                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10832                     t += UTF8SKIP(t);
10833                 if (d + (t - s) > e)
10834                     Perl_croak(aTHX_ ident_too_long);
10835                 Copy(s, d, t - s, char);
10836                 d += t - s;
10837                 s = t;
10838             }
10839             else
10840                 break;
10841         }
10842     }
10843     *d = '\0';
10844     d = dest;
10845     if (*d) {
10846         if (PL_lex_state != LEX_NORMAL)
10847             PL_lex_state = LEX_INTERPENDMAYBE;
10848         return s;
10849     }
10850     if (*s == '$' && s[1] &&
10851         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10852     {
10853         return s;
10854     }
10855     if (*s == '{') {
10856         bracket = s;
10857         s++;
10858     }
10859     else if (ck_uni)
10860         check_uni();
10861     if (s < send)
10862         *d = *s++;
10863     d[1] = '\0';
10864     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10865         *d = toCTRL(*s);
10866         s++;
10867     }
10868     if (bracket) {
10869         if (isSPACE(s[-1])) {
10870             while (s < send) {
10871                 const char ch = *s++;
10872                 if (!SPACE_OR_TAB(ch)) {
10873                     *d = ch;
10874                     break;
10875                 }
10876             }
10877         }
10878         if (isIDFIRST_lazy_if(d,UTF)) {
10879             d++;
10880             if (UTF) {
10881                 char *end = s;
10882                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10883                     end += UTF8SKIP(end);
10884                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10885                         end += UTF8SKIP(end);
10886                 }
10887                 Copy(s, d, end - s, char);
10888                 d += end - s;
10889                 s = end;
10890             }
10891             else {
10892                 while ((isALNUM(*s) || *s == ':') && d < e)
10893                     *d++ = *s++;
10894                 if (d >= e)
10895                     Perl_croak(aTHX_ ident_too_long);
10896             }
10897             *d = '\0';
10898             while (s < send && SPACE_OR_TAB(*s))
10899                 s++;
10900             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10901                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10902                     const char * const brack =
10903                         (const char *)
10904                         ((*s == '[') ? "[...]" : "{...}");
10905                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10906                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10907                         funny, dest, brack, funny, dest, brack);
10908                 }
10909                 bracket++;
10910                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10911                 return s;
10912             }
10913         }
10914         /* Handle extended ${^Foo} variables
10915          * 1999-02-27 mjd-perl-patch@plover.com */
10916         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10917                  && isALNUM(*s))
10918         {
10919             d++;
10920             while (isALNUM(*s) && d < e) {
10921                 *d++ = *s++;
10922             }
10923             if (d >= e)
10924                 Perl_croak(aTHX_ ident_too_long);
10925             *d = '\0';
10926         }
10927         if (*s == '}') {
10928             s++;
10929             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10930                 PL_lex_state = LEX_INTERPEND;
10931                 PL_expect = XREF;
10932             }
10933             if (PL_lex_state == LEX_NORMAL) {
10934                 if (ckWARN(WARN_AMBIGUOUS) &&
10935                     (keyword(dest, d - dest, 0)
10936                      || get_cvn_flags(dest, d - dest, 0)))
10937                 {
10938                     if (funny == '#')
10939                         funny = '@';
10940                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10941                         "Ambiguous use of %c{%s} resolved to %c%s",
10942                         funny, dest, funny, dest);
10943                 }
10944             }
10945         }
10946         else {
10947             s = bracket;                /* let the parser handle it */
10948             *dest = '\0';
10949         }
10950     }
10951     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10952         PL_lex_state = LEX_INTERPEND;
10953     return s;
10954 }
10955
10956 void
10957 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10958 {
10959     PERL_ARGS_ASSERT_PMFLAG;
10960
10961     PERL_UNUSED_CONTEXT;
10962     if (ch<256) {
10963         const char c = (char)ch;
10964         switch (c) {
10965             CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10966             case GLOBAL_PAT_MOD:    *pmfl |= PMf_GLOBAL; break;
10967             case CONTINUE_PAT_MOD:  *pmfl |= PMf_CONTINUE; break;
10968             case ONCE_PAT_MOD:      *pmfl |= PMf_KEEP; break;
10969             case KEEPCOPY_PAT_MOD:  *pmfl |= PMf_KEEPCOPY; break;
10970         }
10971     }
10972 }
10973
10974 STATIC char *
10975 S_scan_pat(pTHX_ char *start, I32 type)
10976 {
10977     dVAR;
10978     PMOP *pm;
10979     char *s = scan_str(start,!!PL_madskills,FALSE);
10980     const char * const valid_flags =
10981         (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10982 #ifdef PERL_MAD
10983     char *modstart;
10984 #endif
10985
10986     PERL_ARGS_ASSERT_SCAN_PAT;
10987
10988     if (!s) {
10989         const char * const delimiter = skipspace(start);
10990         Perl_croak(aTHX_
10991                    (const char *)
10992                    (*delimiter == '?'
10993                     ? "Search pattern not terminated or ternary operator parsed as search pattern"
10994                     : "Search pattern not terminated" ));
10995     }
10996
10997     pm = (PMOP*)newPMOP(type, 0);
10998     if (PL_multi_open == '?') {
10999         /* This is the only point in the code that sets PMf_ONCE:  */
11000         pm->op_pmflags |= PMf_ONCE;
11001
11002         /* Hence it's safe to do this bit of PMOP book-keeping here, which
11003            allows us to restrict the list needed by reset to just the ??
11004            matches.  */
11005         assert(type != OP_TRANS);
11006         if (PL_curstash) {
11007             MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11008             U32 elements;
11009             if (!mg) {
11010                 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11011                                  0);
11012             }
11013             elements = mg->mg_len / sizeof(PMOP**);
11014             Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11015             ((PMOP**)mg->mg_ptr) [elements++] = pm;
11016             mg->mg_len = elements * sizeof(PMOP**);
11017             PmopSTASH_set(pm,PL_curstash);
11018         }
11019     }
11020 #ifdef PERL_MAD
11021     modstart = s;
11022 #endif
11023     while (*s && strchr(valid_flags, *s))
11024         pmflag(&pm->op_pmflags,*s++);
11025 #ifdef PERL_MAD
11026     if (PL_madskills && modstart != s) {
11027         SV* tmptoken = newSVpvn(modstart, s - modstart);
11028         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11029     }
11030 #endif
11031     /* issue a warning if /c is specified,but /g is not */
11032     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
11033             && ckWARN(WARN_REGEXP))
11034     {
11035         Perl_warner(aTHX_ packWARN(WARN_REGEXP),
11036             "Use of /c modifier is meaningless without /g" );
11037     }
11038
11039     PL_lex_op = (OP*)pm;
11040     pl_yylval.ival = OP_MATCH;
11041     return s;
11042 }
11043
11044 STATIC char *
11045 S_scan_subst(pTHX_ char *start)
11046 {
11047     dVAR;
11048     register char *s;
11049     register PMOP *pm;
11050     I32 first_start;
11051     I32 es = 0;
11052 #ifdef PERL_MAD
11053     char *modstart;
11054 #endif
11055
11056     PERL_ARGS_ASSERT_SCAN_SUBST;
11057
11058     pl_yylval.ival = OP_NULL;
11059
11060     s = scan_str(start,!!PL_madskills,FALSE);
11061
11062     if (!s)
11063         Perl_croak(aTHX_ "Substitution pattern not terminated");
11064
11065     if (s[-1] == PL_multi_open)
11066         s--;
11067 #ifdef PERL_MAD
11068     if (PL_madskills) {
11069         CURMAD('q', PL_thisopen);
11070         CURMAD('_', PL_thiswhite);
11071         CURMAD('E', PL_thisstuff);
11072         CURMAD('Q', PL_thisclose);
11073         PL_realtokenstart = s - SvPVX(PL_linestr);
11074     }
11075 #endif
11076
11077     first_start = PL_multi_start;
11078     s = scan_str(s,!!PL_madskills,FALSE);
11079     if (!s) {
11080         if (PL_lex_stuff) {
11081             SvREFCNT_dec(PL_lex_stuff);
11082             PL_lex_stuff = NULL;
11083         }
11084         Perl_croak(aTHX_ "Substitution replacement not terminated");
11085     }
11086     PL_multi_start = first_start;       /* so whole substitution is taken together */
11087
11088     pm = (PMOP*)newPMOP(OP_SUBST, 0);
11089
11090 #ifdef PERL_MAD
11091     if (PL_madskills) {
11092         CURMAD('z', PL_thisopen);
11093         CURMAD('R', PL_thisstuff);
11094         CURMAD('Z', PL_thisclose);
11095     }
11096     modstart = s;
11097 #endif
11098
11099     while (*s) {
11100         if (*s == EXEC_PAT_MOD) {
11101             s++;
11102             es++;
11103         }
11104         else if (strchr(S_PAT_MODS, *s))
11105             pmflag(&pm->op_pmflags,*s++);
11106         else
11107             break;
11108     }
11109
11110 #ifdef PERL_MAD
11111     if (PL_madskills) {
11112         if (modstart != s)
11113             curmad('m', newSVpvn(modstart, s - modstart));
11114         append_madprops(PL_thismad, (OP*)pm, 0);
11115         PL_thismad = 0;
11116     }
11117 #endif
11118     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
11119         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11120     }
11121
11122     if (es) {
11123         SV * const repl = newSVpvs("");
11124
11125         PL_sublex_info.super_bufptr = s;
11126         PL_sublex_info.super_bufend = PL_bufend;
11127         PL_multi_end = 0;
11128         pm->op_pmflags |= PMf_EVAL;
11129         while (es-- > 0) {
11130             if (es)
11131                 sv_catpvs(repl, "eval ");
11132             else
11133                 sv_catpvs(repl, "do ");
11134         }
11135         sv_catpvs(repl, "{");
11136         sv_catsv(repl, PL_lex_repl);
11137         if (strchr(SvPVX(PL_lex_repl), '#'))
11138             sv_catpvs(repl, "\n");
11139         sv_catpvs(repl, "}");
11140         SvEVALED_on(repl);
11141         SvREFCNT_dec(PL_lex_repl);
11142         PL_lex_repl = repl;
11143     }
11144
11145     PL_lex_op = (OP*)pm;
11146     pl_yylval.ival = OP_SUBST;
11147     return s;
11148 }
11149
11150 STATIC char *
11151 S_scan_trans(pTHX_ char *start)
11152 {
11153     dVAR;
11154     register char* s;
11155     OP *o;
11156     short *tbl;
11157     U8 squash;
11158     U8 del;
11159     U8 complement;
11160 #ifdef PERL_MAD
11161     char *modstart;
11162 #endif
11163
11164     PERL_ARGS_ASSERT_SCAN_TRANS;
11165
11166     pl_yylval.ival = OP_NULL;
11167
11168     s = scan_str(start,!!PL_madskills,FALSE);
11169     if (!s)
11170         Perl_croak(aTHX_ "Transliteration pattern not terminated");
11171
11172     if (s[-1] == PL_multi_open)
11173         s--;
11174 #ifdef PERL_MAD
11175     if (PL_madskills) {
11176         CURMAD('q', PL_thisopen);
11177         CURMAD('_', PL_thiswhite);
11178         CURMAD('E', PL_thisstuff);
11179         CURMAD('Q', PL_thisclose);
11180         PL_realtokenstart = s - SvPVX(PL_linestr);
11181     }
11182 #endif
11183
11184     s = scan_str(s,!!PL_madskills,FALSE);
11185     if (!s) {
11186         if (PL_lex_stuff) {
11187             SvREFCNT_dec(PL_lex_stuff);
11188             PL_lex_stuff = NULL;
11189         }
11190         Perl_croak(aTHX_ "Transliteration replacement not terminated");
11191     }
11192     if (PL_madskills) {
11193         CURMAD('z', PL_thisopen);
11194         CURMAD('R', PL_thisstuff);
11195         CURMAD('Z', PL_thisclose);
11196     }
11197
11198     complement = del = squash = 0;
11199 #ifdef PERL_MAD
11200     modstart = s;
11201 #endif
11202     while (1) {
11203         switch (*s) {
11204         case 'c':
11205             complement = OPpTRANS_COMPLEMENT;
11206             break;
11207         case 'd':
11208             del = OPpTRANS_DELETE;
11209             break;
11210         case 's':
11211             squash = OPpTRANS_SQUASH;
11212             break;
11213         default:
11214             goto no_more;
11215         }
11216         s++;
11217     }
11218   no_more:
11219
11220     tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11221     o = newPVOP(OP_TRANS, 0, (char*)tbl);
11222     o->op_private &= ~OPpTRANS_ALL;
11223     o->op_private |= del|squash|complement|
11224       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11225       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
11226
11227     PL_lex_op = o;
11228     pl_yylval.ival = OP_TRANS;
11229
11230 #ifdef PERL_MAD
11231     if (PL_madskills) {
11232         if (modstart != s)
11233             curmad('m', newSVpvn(modstart, s - modstart));
11234         append_madprops(PL_thismad, o, 0);
11235         PL_thismad = 0;
11236     }
11237 #endif
11238
11239     return s;
11240 }
11241
11242 STATIC char *
11243 S_scan_heredoc(pTHX_ register char *s)
11244 {
11245     dVAR;
11246     SV *herewas;
11247     I32 op_type = OP_SCALAR;
11248     I32 len;
11249     SV *tmpstr;
11250     char term;
11251     const char *found_newline;
11252     register char *d;
11253     register char *e;
11254     char *peek;
11255     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11256 #ifdef PERL_MAD
11257     I32 stuffstart = s - SvPVX(PL_linestr);
11258     char *tstart;
11259
11260     PL_realtokenstart = -1;
11261 #endif
11262
11263     PERL_ARGS_ASSERT_SCAN_HEREDOC;
11264
11265     s += 2;
11266     d = PL_tokenbuf;
11267     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11268     if (!outer)
11269         *d++ = '\n';
11270     peek = s;
11271     while (SPACE_OR_TAB(*peek))
11272         peek++;
11273     if (*peek == '`' || *peek == '\'' || *peek =='"') {
11274         s = peek;
11275         term = *s++;
11276         s = delimcpy(d, e, s, PL_bufend, term, &len);
11277         d += len;
11278         if (s < PL_bufend)
11279             s++;
11280     }
11281     else {
11282         if (*s == '\\')
11283             s++, term = '\'';
11284         else
11285             term = '"';
11286         if (!isALNUM_lazy_if(s,UTF))
11287             deprecate_old("bare << to mean <<\"\"");
11288         for (; isALNUM_lazy_if(s,UTF); s++) {
11289             if (d < e)
11290                 *d++ = *s;
11291         }
11292     }
11293     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11294         Perl_croak(aTHX_ "Delimiter for here document is too long");
11295     *d++ = '\n';
11296     *d = '\0';
11297     len = d - PL_tokenbuf;
11298
11299 #ifdef PERL_MAD
11300     if (PL_madskills) {
11301         tstart = PL_tokenbuf + !outer;
11302         PL_thisclose = newSVpvn(tstart, len - !outer);
11303         tstart = SvPVX(PL_linestr) + stuffstart;
11304         PL_thisopen = newSVpvn(tstart, s - tstart);
11305         stuffstart = s - SvPVX(PL_linestr);
11306     }
11307 #endif
11308 #ifndef PERL_STRICT_CR
11309     d = strchr(s, '\r');
11310     if (d) {
11311         char * const olds = s;
11312         s = d;
11313         while (s < PL_bufend) {
11314             if (*s == '\r') {
11315                 *d++ = '\n';
11316                 if (*++s == '\n')
11317                     s++;
11318             }
11319             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
11320                 *d++ = *s++;
11321                 s++;
11322             }
11323             else
11324                 *d++ = *s++;
11325         }
11326         *d = '\0';
11327         PL_bufend = d;
11328         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11329         s = olds;
11330     }
11331 #endif
11332 #ifdef PERL_MAD
11333     found_newline = 0;
11334 #endif
11335     if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11336         herewas = newSVpvn(s,PL_bufend-s);
11337     }
11338     else {
11339 #ifdef PERL_MAD
11340         herewas = newSVpvn(s-1,found_newline-s+1);
11341 #else
11342         s--;
11343         herewas = newSVpvn(s,found_newline-s);
11344 #endif
11345     }
11346 #ifdef PERL_MAD
11347     if (PL_madskills) {
11348         tstart = SvPVX(PL_linestr) + stuffstart;
11349         if (PL_thisstuff)
11350             sv_catpvn(PL_thisstuff, tstart, s - tstart);
11351         else
11352             PL_thisstuff = newSVpvn(tstart, s - tstart);
11353     }
11354 #endif
11355     s += SvCUR(herewas);
11356
11357 #ifdef PERL_MAD
11358     stuffstart = s - SvPVX(PL_linestr);
11359
11360     if (found_newline)
11361         s--;
11362 #endif
11363
11364     tmpstr = newSV_type(SVt_PVIV);
11365     SvGROW(tmpstr, 80);
11366     if (term == '\'') {
11367         op_type = OP_CONST;
11368         SvIV_set(tmpstr, -1);
11369     }
11370     else if (term == '`') {
11371         op_type = OP_BACKTICK;
11372         SvIV_set(tmpstr, '\\');
11373     }
11374
11375     CLINE;
11376     PL_multi_start = CopLINE(PL_curcop);
11377     PL_multi_open = PL_multi_close = '<';
11378     term = *PL_tokenbuf;
11379     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11380         char * const bufptr = PL_sublex_info.super_bufptr;
11381         char * const bufend = PL_sublex_info.super_bufend;
11382         char * const olds = s - SvCUR(herewas);
11383         s = strchr(bufptr, '\n');
11384         if (!s)
11385             s = bufend;
11386         d = s;
11387         while (s < bufend &&
11388           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11389             if (*s++ == '\n')
11390                 CopLINE_inc(PL_curcop);
11391         }
11392         if (s >= bufend) {
11393             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11394             missingterm(PL_tokenbuf);
11395         }
11396         sv_setpvn(herewas,bufptr,d-bufptr+1);
11397         sv_setpvn(tmpstr,d+1,s-d);
11398         s += len - 1;
11399         sv_catpvn(herewas,s,bufend-s);
11400         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11401
11402         s = olds;
11403         goto retval;
11404     }
11405     else if (!outer) {
11406         d = s;
11407         while (s < PL_bufend &&
11408           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11409             if (*s++ == '\n')
11410                 CopLINE_inc(PL_curcop);
11411         }
11412         if (s >= PL_bufend) {
11413             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11414             missingterm(PL_tokenbuf);
11415         }
11416         sv_setpvn(tmpstr,d+1,s-d);
11417 #ifdef PERL_MAD
11418         if (PL_madskills) {
11419             if (PL_thisstuff)
11420                 sv_catpvn(PL_thisstuff, d + 1, s - d);
11421             else
11422                 PL_thisstuff = newSVpvn(d + 1, s - d);
11423             stuffstart = s - SvPVX(PL_linestr);
11424         }
11425 #endif
11426         s += len - 1;
11427         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11428
11429         sv_catpvn(herewas,s,PL_bufend-s);
11430         sv_setsv(PL_linestr,herewas);
11431         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11432         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11433         PL_last_lop = PL_last_uni = NULL;
11434     }
11435     else
11436         sv_setpvs(tmpstr,"");   /* avoid "uninitialized" warning */
11437     while (s >= PL_bufend) {    /* multiple line string? */
11438 #ifdef PERL_MAD
11439         if (PL_madskills) {
11440             tstart = SvPVX(PL_linestr) + stuffstart;
11441             if (PL_thisstuff)
11442                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11443             else
11444                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11445         }
11446 #endif
11447         if (!outer ||
11448          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11449             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11450             missingterm(PL_tokenbuf);
11451         }
11452 #ifdef PERL_MAD
11453         stuffstart = s - SvPVX(PL_linestr);
11454 #endif
11455         CopLINE_inc(PL_curcop);
11456         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11457         PL_last_lop = PL_last_uni = NULL;
11458 #ifndef PERL_STRICT_CR
11459         if (PL_bufend - PL_linestart >= 2) {
11460             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11461                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11462             {
11463                 PL_bufend[-2] = '\n';
11464                 PL_bufend--;
11465                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11466             }
11467             else if (PL_bufend[-1] == '\r')
11468                 PL_bufend[-1] = '\n';
11469         }
11470         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11471             PL_bufend[-1] = '\n';
11472 #endif
11473         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11474             update_debugger_info(PL_linestr, NULL, 0);
11475         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11476             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11477             *(SvPVX(PL_linestr) + off ) = ' ';
11478             sv_catsv(PL_linestr,herewas);
11479             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11480             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11481         }
11482         else {
11483             s = PL_bufend;
11484             sv_catsv(tmpstr,PL_linestr);
11485         }
11486     }
11487     s++;
11488 retval:
11489     PL_multi_end = CopLINE(PL_curcop);
11490     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11491         SvPV_shrink_to_cur(tmpstr);
11492     }
11493     SvREFCNT_dec(herewas);
11494     if (!IN_BYTES) {
11495         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11496             SvUTF8_on(tmpstr);
11497         else if (PL_encoding)
11498             sv_recode_to_utf8(tmpstr, PL_encoding);
11499     }
11500     PL_lex_stuff = tmpstr;
11501     pl_yylval.ival = op_type;
11502     return s;
11503 }
11504
11505 /* scan_inputsymbol
11506    takes: current position in input buffer
11507    returns: new position in input buffer
11508    side-effects: pl_yylval and lex_op are set.
11509
11510    This code handles:
11511
11512    <>           read from ARGV
11513    <FH>         read from filehandle
11514    <pkg::FH>    read from package qualified filehandle
11515    <pkg'FH>     read from package qualified filehandle
11516    <$fh>        read from filehandle in $fh
11517    <*.h>        filename glob
11518
11519 */
11520
11521 STATIC char *
11522 S_scan_inputsymbol(pTHX_ char *start)
11523 {
11524     dVAR;
11525     register char *s = start;           /* current position in buffer */
11526     char *end;
11527     I32 len;
11528     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11529     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11530
11531     PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11532
11533     end = strchr(s, '\n');
11534     if (!end)
11535         end = PL_bufend;
11536     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11537
11538     /* die if we didn't have space for the contents of the <>,
11539        or if it didn't end, or if we see a newline
11540     */
11541
11542     if (len >= (I32)sizeof PL_tokenbuf)
11543         Perl_croak(aTHX_ "Excessively long <> operator");
11544     if (s >= end)
11545         Perl_croak(aTHX_ "Unterminated <> operator");
11546
11547     s++;
11548
11549     /* check for <$fh>
11550        Remember, only scalar variables are interpreted as filehandles by
11551        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11552        treated as a glob() call.
11553        This code makes use of the fact that except for the $ at the front,
11554        a scalar variable and a filehandle look the same.
11555     */
11556     if (*d == '$' && d[1]) d++;
11557
11558     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11559     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11560         d++;
11561
11562     /* If we've tried to read what we allow filehandles to look like, and
11563        there's still text left, then it must be a glob() and not a getline.
11564        Use scan_str to pull out the stuff between the <> and treat it
11565        as nothing more than a string.
11566     */
11567
11568     if (d - PL_tokenbuf != len) {
11569         pl_yylval.ival = OP_GLOB;
11570         s = scan_str(start,!!PL_madskills,FALSE);
11571         if (!s)
11572            Perl_croak(aTHX_ "Glob not terminated");
11573         return s;
11574     }
11575     else {
11576         bool readline_overriden = FALSE;
11577         GV *gv_readline;
11578         GV **gvp;
11579         /* we're in a filehandle read situation */
11580         d = PL_tokenbuf;
11581
11582         /* turn <> into <ARGV> */
11583         if (!len)
11584             Copy("ARGV",d,5,char);
11585
11586         /* Check whether readline() is overriden */
11587         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11588         if ((gv_readline
11589                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11590                 ||
11591                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11592                  && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11593                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11594             readline_overriden = TRUE;
11595
11596         /* if <$fh>, create the ops to turn the variable into a
11597            filehandle
11598         */
11599         if (*d == '$') {
11600             /* try to find it in the pad for this block, otherwise find
11601                add symbol table ops
11602             */
11603             const PADOFFSET tmp = pad_findmy(d);
11604             if (tmp != NOT_IN_PAD) {
11605                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11606                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11607                     HEK * const stashname = HvNAME_HEK(stash);
11608                     SV * const sym = sv_2mortal(newSVhek(stashname));
11609                     sv_catpvs(sym, "::");
11610                     sv_catpv(sym, d+1);
11611                     d = SvPVX(sym);
11612                     goto intro_sym;
11613                 }
11614                 else {
11615                     OP * const o = newOP(OP_PADSV, 0);
11616                     o->op_targ = tmp;
11617                     PL_lex_op = readline_overriden
11618                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11619                                 append_elem(OP_LIST, o,
11620                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11621                         : (OP*)newUNOP(OP_READLINE, 0, o);
11622                 }
11623             }
11624             else {
11625                 GV *gv;
11626                 ++d;
11627 intro_sym:
11628                 gv = gv_fetchpv(d,
11629                                 (PL_in_eval
11630                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11631                                  : GV_ADDMULTI),
11632                                 SVt_PV);
11633                 PL_lex_op = readline_overriden
11634                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11635                             append_elem(OP_LIST,
11636                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11637                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11638                     : (OP*)newUNOP(OP_READLINE, 0,
11639                             newUNOP(OP_RV2SV, 0,
11640                                 newGVOP(OP_GV, 0, gv)));
11641             }
11642             if (!readline_overriden)
11643                 PL_lex_op->op_flags |= OPf_SPECIAL;
11644             /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11645             pl_yylval.ival = OP_NULL;
11646         }
11647
11648         /* If it's none of the above, it must be a literal filehandle
11649            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11650         else {
11651             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11652             PL_lex_op = readline_overriden
11653                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11654                         append_elem(OP_LIST,
11655                             newGVOP(OP_GV, 0, gv),
11656                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11657                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11658             pl_yylval.ival = OP_NULL;
11659         }
11660     }
11661
11662     return s;
11663 }
11664
11665
11666 /* scan_str
11667    takes: start position in buffer
11668           keep_quoted preserve \ on the embedded delimiter(s)
11669           keep_delims preserve the delimiters around the string
11670    returns: position to continue reading from buffer
11671    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11672         updates the read buffer.
11673
11674    This subroutine pulls a string out of the input.  It is called for:
11675         q               single quotes           q(literal text)
11676         '               single quotes           'literal text'
11677         qq              double quotes           qq(interpolate $here please)
11678         "               double quotes           "interpolate $here please"
11679         qx              backticks               qx(/bin/ls -l)
11680         `               backticks               `/bin/ls -l`
11681         qw              quote words             @EXPORT_OK = qw( func() $spam )
11682         m//             regexp match            m/this/
11683         s///            regexp substitute       s/this/that/
11684         tr///           string transliterate    tr/this/that/
11685         y///            string transliterate    y/this/that/
11686         ($*@)           sub prototypes          sub foo ($)
11687         (stuff)         sub attr parameters     sub foo : attr(stuff)
11688         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11689
11690    In most of these cases (all but <>, patterns and transliterate)
11691    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11692    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11693    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11694    calls scan_str().
11695
11696    It skips whitespace before the string starts, and treats the first
11697    character as the delimiter.  If the delimiter is one of ([{< then
11698    the corresponding "close" character )]}> is used as the closing
11699    delimiter.  It allows quoting of delimiters, and if the string has
11700    balanced delimiters ([{<>}]) it allows nesting.
11701
11702    On success, the SV with the resulting string is put into lex_stuff or,
11703    if that is already non-NULL, into lex_repl. The second case occurs only
11704    when parsing the RHS of the special constructs s/// and tr/// (y///).
11705    For convenience, the terminating delimiter character is stuffed into
11706    SvIVX of the SV.
11707 */
11708
11709 STATIC char *
11710 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11711 {
11712     dVAR;
11713     SV *sv;                             /* scalar value: string */
11714     const char *tmps;                   /* temp string, used for delimiter matching */
11715     register char *s = start;           /* current position in the buffer */
11716     register char term;                 /* terminating character */
11717     register char *to;                  /* current position in the sv's data */
11718     I32 brackets = 1;                   /* bracket nesting level */
11719     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11720     I32 termcode;                       /* terminating char. code */
11721     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11722     STRLEN termlen;                     /* length of terminating string */
11723     int last_off = 0;                   /* last position for nesting bracket */
11724 #ifdef PERL_MAD
11725     int stuffstart;
11726     char *tstart;
11727 #endif
11728
11729     PERL_ARGS_ASSERT_SCAN_STR;
11730
11731     /* skip space before the delimiter */
11732     if (isSPACE(*s)) {
11733         s = PEEKSPACE(s);
11734     }
11735
11736 #ifdef PERL_MAD
11737     if (PL_realtokenstart >= 0) {
11738         stuffstart = PL_realtokenstart;
11739         PL_realtokenstart = -1;
11740     }
11741     else
11742         stuffstart = start - SvPVX(PL_linestr);
11743 #endif
11744     /* mark where we are, in case we need to report errors */
11745     CLINE;
11746
11747     /* after skipping whitespace, the next character is the terminator */
11748     term = *s;
11749     if (!UTF) {
11750         termcode = termstr[0] = term;
11751         termlen = 1;
11752     }
11753     else {
11754         termcode = utf8_to_uvchr((U8*)s, &termlen);
11755         Copy(s, termstr, termlen, U8);
11756         if (!UTF8_IS_INVARIANT(term))
11757             has_utf8 = TRUE;
11758     }
11759
11760     /* mark where we are */
11761     PL_multi_start = CopLINE(PL_curcop);
11762     PL_multi_open = term;
11763
11764     /* find corresponding closing delimiter */
11765     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11766         termcode = termstr[0] = term = tmps[5];
11767
11768     PL_multi_close = term;
11769
11770     /* create a new SV to hold the contents.  79 is the SV's initial length.
11771        What a random number. */
11772     sv = newSV_type(SVt_PVIV);
11773     SvGROW(sv, 80);
11774     SvIV_set(sv, termcode);
11775     (void)SvPOK_only(sv);               /* validate pointer */
11776
11777     /* move past delimiter and try to read a complete string */
11778     if (keep_delims)
11779         sv_catpvn(sv, s, termlen);
11780     s += termlen;
11781 #ifdef PERL_MAD
11782     tstart = SvPVX(PL_linestr) + stuffstart;
11783     if (!PL_thisopen && !keep_delims) {
11784         PL_thisopen = newSVpvn(tstart, s - tstart);
11785         stuffstart = s - SvPVX(PL_linestr);
11786     }
11787 #endif
11788     for (;;) {
11789         if (PL_encoding && !UTF) {
11790             bool cont = TRUE;
11791
11792             while (cont) {
11793                 int offset = s - SvPVX_const(PL_linestr);
11794                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11795                                            &offset, (char*)termstr, termlen);
11796                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11797                 char * const svlast = SvEND(sv) - 1;
11798
11799                 for (; s < ns; s++) {
11800                     if (*s == '\n' && !PL_rsfp)
11801                         CopLINE_inc(PL_curcop);
11802                 }
11803                 if (!found)
11804                     goto read_more_line;
11805                 else {
11806                     /* handle quoted delimiters */
11807                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11808                         const char *t;
11809                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11810                             t--;
11811                         if ((svlast-1 - t) % 2) {
11812                             if (!keep_quoted) {
11813                                 *(svlast-1) = term;
11814                                 *svlast = '\0';
11815                                 SvCUR_set(sv, SvCUR(sv) - 1);
11816                             }
11817                             continue;
11818                         }
11819                     }
11820                     if (PL_multi_open == PL_multi_close) {
11821                         cont = FALSE;
11822                     }
11823                     else {
11824                         const char *t;
11825                         char *w;
11826                         for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11827                             /* At here, all closes are "was quoted" one,
11828                                so we don't check PL_multi_close. */
11829                             if (*t == '\\') {
11830                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11831                                     t++;
11832                                 else
11833                                     *w++ = *t++;
11834                             }
11835                             else if (*t == PL_multi_open)
11836                                 brackets++;
11837
11838                             *w = *t;
11839                         }
11840                         if (w < t) {
11841                             *w++ = term;
11842                             *w = '\0';
11843                             SvCUR_set(sv, w - SvPVX_const(sv));
11844                         }
11845                         last_off = w - SvPVX(sv);
11846                         if (--brackets <= 0)
11847                             cont = FALSE;
11848                     }
11849                 }
11850             }
11851             if (!keep_delims) {
11852                 SvCUR_set(sv, SvCUR(sv) - 1);
11853                 *SvEND(sv) = '\0';
11854             }
11855             break;
11856         }
11857
11858         /* extend sv if need be */
11859         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11860         /* set 'to' to the next character in the sv's string */
11861         to = SvPVX(sv)+SvCUR(sv);
11862
11863         /* if open delimiter is the close delimiter read unbridle */
11864         if (PL_multi_open == PL_multi_close) {
11865             for (; s < PL_bufend; s++,to++) {
11866                 /* embedded newlines increment the current line number */
11867                 if (*s == '\n' && !PL_rsfp)
11868                     CopLINE_inc(PL_curcop);
11869                 /* handle quoted delimiters */
11870                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11871                     if (!keep_quoted && s[1] == term)
11872                         s++;
11873                 /* any other quotes are simply copied straight through */
11874                     else
11875                         *to++ = *s++;
11876                 }
11877                 /* terminate when run out of buffer (the for() condition), or
11878                    have found the terminator */
11879                 else if (*s == term) {
11880                     if (termlen == 1)
11881                         break;
11882                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11883                         break;
11884                 }
11885                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11886                     has_utf8 = TRUE;
11887                 *to = *s;
11888             }
11889         }
11890
11891         /* if the terminator isn't the same as the start character (e.g.,
11892            matched brackets), we have to allow more in the quoting, and
11893            be prepared for nested brackets.
11894         */
11895         else {
11896             /* read until we run out of string, or we find the terminator */
11897             for (; s < PL_bufend; s++,to++) {
11898                 /* embedded newlines increment the line count */
11899                 if (*s == '\n' && !PL_rsfp)
11900                     CopLINE_inc(PL_curcop);
11901                 /* backslashes can escape the open or closing characters */
11902                 if (*s == '\\' && s+1 < PL_bufend) {
11903                     if (!keep_quoted &&
11904                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11905                         s++;
11906                     else
11907                         *to++ = *s++;
11908                 }
11909                 /* allow nested opens and closes */
11910                 else if (*s == PL_multi_close && --brackets <= 0)
11911                     break;
11912                 else if (*s == PL_multi_open)
11913                     brackets++;
11914                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11915                     has_utf8 = TRUE;
11916                 *to = *s;
11917             }
11918         }
11919         /* terminate the copied string and update the sv's end-of-string */
11920         *to = '\0';
11921         SvCUR_set(sv, to - SvPVX_const(sv));
11922
11923         /*
11924          * this next chunk reads more into the buffer if we're not done yet
11925          */
11926
11927         if (s < PL_bufend)
11928             break;              /* handle case where we are done yet :-) */
11929
11930 #ifndef PERL_STRICT_CR
11931         if (to - SvPVX_const(sv) >= 2) {
11932             if ((to[-2] == '\r' && to[-1] == '\n') ||
11933                 (to[-2] == '\n' && to[-1] == '\r'))
11934             {
11935                 to[-2] = '\n';
11936                 to--;
11937                 SvCUR_set(sv, to - SvPVX_const(sv));
11938             }
11939             else if (to[-1] == '\r')
11940                 to[-1] = '\n';
11941         }
11942         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11943             to[-1] = '\n';
11944 #endif
11945
11946      read_more_line:
11947         /* if we're out of file, or a read fails, bail and reset the current
11948            line marker so we can report where the unterminated string began
11949         */
11950 #ifdef PERL_MAD
11951         if (PL_madskills) {
11952             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11953             if (PL_thisstuff)
11954                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11955             else
11956                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11957         }
11958 #endif
11959         if (!PL_rsfp ||
11960          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11961             sv_free(sv);
11962             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11963             return NULL;
11964         }
11965 #ifdef PERL_MAD
11966         stuffstart = 0;
11967 #endif
11968         /* we read a line, so increment our line counter */
11969         CopLINE_inc(PL_curcop);
11970
11971         /* update debugger info */
11972         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11973             update_debugger_info(PL_linestr, NULL, 0);
11974
11975         /* having changed the buffer, we must update PL_bufend */
11976         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11977         PL_last_lop = PL_last_uni = NULL;
11978     }
11979
11980     /* at this point, we have successfully read the delimited string */
11981
11982     if (!PL_encoding || UTF) {
11983 #ifdef PERL_MAD
11984         if (PL_madskills) {
11985             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11986             const int len = s - tstart;
11987             if (PL_thisstuff)
11988                 sv_catpvn(PL_thisstuff, tstart, len);
11989             else
11990                 PL_thisstuff = newSVpvn(tstart, len);
11991             if (!PL_thisclose && !keep_delims)
11992                 PL_thisclose = newSVpvn(s,termlen);
11993         }
11994 #endif
11995
11996         if (keep_delims)
11997             sv_catpvn(sv, s, termlen);
11998         s += termlen;
11999     }
12000 #ifdef PERL_MAD
12001     else {
12002         if (PL_madskills) {
12003             char * const tstart = SvPVX(PL_linestr) + stuffstart;
12004             const int len = s - tstart - termlen;
12005             if (PL_thisstuff)
12006                 sv_catpvn(PL_thisstuff, tstart, len);
12007             else
12008                 PL_thisstuff = newSVpvn(tstart, len);
12009             if (!PL_thisclose && !keep_delims)
12010                 PL_thisclose = newSVpvn(s - termlen,termlen);
12011         }
12012     }
12013 #endif
12014     if (has_utf8 || PL_encoding)
12015         SvUTF8_on(sv);
12016
12017     PL_multi_end = CopLINE(PL_curcop);
12018
12019     /* if we allocated too much space, give some back */
12020     if (SvCUR(sv) + 5 < SvLEN(sv)) {
12021         SvLEN_set(sv, SvCUR(sv) + 1);
12022         SvPV_renew(sv, SvLEN(sv));
12023     }
12024
12025     /* decide whether this is the first or second quoted string we've read
12026        for this op
12027     */
12028
12029     if (PL_lex_stuff)
12030         PL_lex_repl = sv;
12031     else
12032         PL_lex_stuff = sv;
12033     return s;
12034 }
12035
12036 /*
12037   scan_num
12038   takes: pointer to position in buffer
12039   returns: pointer to new position in buffer
12040   side-effects: builds ops for the constant in pl_yylval.op
12041
12042   Read a number in any of the formats that Perl accepts:
12043
12044   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
12045   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
12046   0b[01](_?[01])*
12047   0[0-7](_?[0-7])*
12048   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12049
12050   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12051   thing it reads.
12052
12053   If it reads a number without a decimal point or an exponent, it will
12054   try converting the number to an integer and see if it can do so
12055   without loss of precision.
12056 */
12057
12058 char *
12059 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12060 {
12061     dVAR;
12062     register const char *s = start;     /* current position in buffer */
12063     register char *d;                   /* destination in temp buffer */
12064     register char *e;                   /* end of temp buffer */
12065     NV nv;                              /* number read, as a double */
12066     SV *sv = NULL;                      /* place to put the converted number */
12067     bool floatit;                       /* boolean: int or float? */
12068     const char *lastub = NULL;          /* position of last underbar */
12069     static char const number_too_long[] = "Number too long";
12070
12071     PERL_ARGS_ASSERT_SCAN_NUM;
12072
12073     /* We use the first character to decide what type of number this is */
12074
12075     switch (*s) {
12076     default:
12077       Perl_croak(aTHX_ "panic: scan_num");
12078
12079     /* if it starts with a 0, it could be an octal number, a decimal in
12080        0.13 disguise, or a hexadecimal number, or a binary number. */
12081     case '0':
12082         {
12083           /* variables:
12084              u          holds the "number so far"
12085              shift      the power of 2 of the base
12086                         (hex == 4, octal == 3, binary == 1)
12087              overflowed was the number more than we can hold?
12088
12089              Shift is used when we add a digit.  It also serves as an "are
12090              we in octal/hex/binary?" indicator to disallow hex characters
12091              when in octal mode.
12092            */
12093             NV n = 0.0;
12094             UV u = 0;
12095             I32 shift;
12096             bool overflowed = FALSE;
12097             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
12098             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12099             static const char* const bases[5] =
12100               { "", "binary", "", "octal", "hexadecimal" };
12101             static const char* const Bases[5] =
12102               { "", "Binary", "", "Octal", "Hexadecimal" };
12103             static const char* const maxima[5] =
12104               { "",
12105                 "0b11111111111111111111111111111111",
12106                 "",
12107                 "037777777777",
12108                 "0xffffffff" };
12109             const char *base, *Base, *max;
12110
12111             /* check for hex */
12112             if (s[1] == 'x') {
12113                 shift = 4;
12114                 s += 2;
12115                 just_zero = FALSE;
12116             } else if (s[1] == 'b') {
12117                 shift = 1;
12118                 s += 2;
12119                 just_zero = FALSE;
12120             }
12121             /* check for a decimal in disguise */
12122             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12123                 goto decimal;
12124             /* so it must be octal */
12125             else {
12126                 shift = 3;
12127                 s++;
12128             }
12129
12130             if (*s == '_') {
12131                if (ckWARN(WARN_SYNTAX))
12132                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12133                                "Misplaced _ in number");
12134                lastub = s++;
12135             }
12136
12137             base = bases[shift];
12138             Base = Bases[shift];
12139             max  = maxima[shift];
12140
12141             /* read the rest of the number */
12142             for (;;) {
12143                 /* x is used in the overflow test,
12144                    b is the digit we're adding on. */
12145                 UV x, b;
12146
12147                 switch (*s) {
12148
12149                 /* if we don't mention it, we're done */
12150                 default:
12151                     goto out;
12152
12153                 /* _ are ignored -- but warned about if consecutive */
12154                 case '_':
12155                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12156                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12157                                     "Misplaced _ in number");
12158                     lastub = s++;
12159                     break;
12160
12161                 /* 8 and 9 are not octal */
12162                 case '8': case '9':
12163                     if (shift == 3)
12164                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12165                     /* FALL THROUGH */
12166
12167                 /* octal digits */
12168                 case '2': case '3': case '4':
12169                 case '5': case '6': case '7':
12170                     if (shift == 1)
12171                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12172                     /* FALL THROUGH */
12173
12174                 case '0': case '1':
12175                     b = *s++ & 15;              /* ASCII digit -> value of digit */
12176                     goto digit;
12177
12178                 /* hex digits */
12179                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12180                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12181                     /* make sure they said 0x */
12182                     if (shift != 4)
12183                         goto out;
12184                     b = (*s++ & 7) + 9;
12185
12186                     /* Prepare to put the digit we have onto the end
12187                        of the number so far.  We check for overflows.
12188                     */
12189
12190                   digit:
12191                     just_zero = FALSE;
12192                     if (!overflowed) {
12193                         x = u << shift; /* make room for the digit */
12194
12195                         if ((x >> shift) != u
12196                             && !(PL_hints & HINT_NEW_BINARY)) {
12197                             overflowed = TRUE;
12198                             n = (NV) u;
12199                             if (ckWARN_d(WARN_OVERFLOW))
12200                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12201                                             "Integer overflow in %s number",
12202                                             base);
12203                         } else
12204                             u = x | b;          /* add the digit to the end */
12205                     }
12206                     if (overflowed) {
12207                         n *= nvshift[shift];
12208                         /* If an NV has not enough bits in its
12209                          * mantissa to represent an UV this summing of
12210                          * small low-order numbers is a waste of time
12211                          * (because the NV cannot preserve the
12212                          * low-order bits anyway): we could just
12213                          * remember when did we overflow and in the
12214                          * end just multiply n by the right
12215                          * amount. */
12216                         n += (NV) b;
12217                     }
12218                     break;
12219                 }
12220             }
12221
12222           /* if we get here, we had success: make a scalar value from
12223              the number.
12224           */
12225           out:
12226
12227             /* final misplaced underbar check */
12228             if (s[-1] == '_') {
12229                 if (ckWARN(WARN_SYNTAX))
12230                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12231             }
12232
12233             sv = newSV(0);
12234             if (overflowed) {
12235                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12236                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12237                                 "%s number > %s non-portable",
12238                                 Base, max);
12239                 sv_setnv(sv, n);
12240             }
12241             else {
12242 #if UVSIZE > 4
12243                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12244                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12245                                 "%s number > %s non-portable",
12246                                 Base, max);
12247 #endif
12248                 sv_setuv(sv, u);
12249             }
12250             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12251                 sv = new_constant(start, s - start, "integer",
12252                                   sv, NULL, NULL, 0);
12253             else if (PL_hints & HINT_NEW_BINARY)
12254                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12255         }
12256         break;
12257
12258     /*
12259       handle decimal numbers.
12260       we're also sent here when we read a 0 as the first digit
12261     */
12262     case '1': case '2': case '3': case '4': case '5':
12263     case '6': case '7': case '8': case '9': case '.':
12264       decimal:
12265         d = PL_tokenbuf;
12266         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12267         floatit = FALSE;
12268
12269         /* read next group of digits and _ and copy into d */
12270         while (isDIGIT(*s) || *s == '_') {
12271             /* skip underscores, checking for misplaced ones
12272                if -w is on
12273             */
12274             if (*s == '_') {
12275                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12276                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12277                                 "Misplaced _ in number");
12278                 lastub = s++;
12279             }
12280             else {
12281                 /* check for end of fixed-length buffer */
12282                 if (d >= e)
12283                     Perl_croak(aTHX_ number_too_long);
12284                 /* if we're ok, copy the character */
12285                 *d++ = *s++;
12286             }
12287         }
12288
12289         /* final misplaced underbar check */
12290         if (lastub && s == lastub + 1) {
12291             if (ckWARN(WARN_SYNTAX))
12292                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12293         }
12294
12295         /* read a decimal portion if there is one.  avoid
12296            3..5 being interpreted as the number 3. followed
12297            by .5
12298         */
12299         if (*s == '.' && s[1] != '.') {
12300             floatit = TRUE;
12301             *d++ = *s++;
12302
12303             if (*s == '_') {
12304                 if (ckWARN(WARN_SYNTAX))
12305                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12306                                 "Misplaced _ in number");
12307                 lastub = s;
12308             }
12309
12310             /* copy, ignoring underbars, until we run out of digits.
12311             */
12312             for (; isDIGIT(*s) || *s == '_'; s++) {
12313                 /* fixed length buffer check */
12314                 if (d >= e)
12315                     Perl_croak(aTHX_ number_too_long);
12316                 if (*s == '_') {
12317                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12318                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12319                                    "Misplaced _ in number");
12320                    lastub = s;
12321                 }
12322                 else
12323                     *d++ = *s;
12324             }
12325             /* fractional part ending in underbar? */
12326             if (s[-1] == '_') {
12327                 if (ckWARN(WARN_SYNTAX))
12328                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12329                                 "Misplaced _ in number");
12330             }
12331             if (*s == '.' && isDIGIT(s[1])) {
12332                 /* oops, it's really a v-string, but without the "v" */
12333                 s = start;
12334                 goto vstring;
12335             }
12336         }
12337
12338         /* read exponent part, if present */
12339         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12340             floatit = TRUE;
12341             s++;
12342
12343             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12344             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
12345
12346             /* stray preinitial _ */
12347             if (*s == '_') {
12348                 if (ckWARN(WARN_SYNTAX))
12349                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12350                                 "Misplaced _ in number");
12351                 lastub = s++;
12352             }
12353
12354             /* allow positive or negative exponent */
12355             if (*s == '+' || *s == '-')
12356                 *d++ = *s++;
12357
12358             /* stray initial _ */
12359             if (*s == '_') {
12360                 if (ckWARN(WARN_SYNTAX))
12361                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12362                                 "Misplaced _ in number");
12363                 lastub = s++;
12364             }
12365
12366             /* read digits of exponent */
12367             while (isDIGIT(*s) || *s == '_') {
12368                 if (isDIGIT(*s)) {
12369                     if (d >= e)
12370                         Perl_croak(aTHX_ number_too_long);
12371                     *d++ = *s++;
12372                 }
12373                 else {
12374                    if (((lastub && s == lastub + 1) ||
12375                         (!isDIGIT(s[1]) && s[1] != '_'))
12376                     && ckWARN(WARN_SYNTAX))
12377                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12378                                    "Misplaced _ in number");
12379                    lastub = s++;
12380                 }
12381             }
12382         }
12383
12384
12385         /* make an sv from the string */
12386         sv = newSV(0);
12387
12388         /*
12389            We try to do an integer conversion first if no characters
12390            indicating "float" have been found.
12391          */
12392
12393         if (!floatit) {
12394             UV uv;
12395             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12396
12397             if (flags == IS_NUMBER_IN_UV) {
12398               if (uv <= IV_MAX)
12399                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12400               else
12401                 sv_setuv(sv, uv);
12402             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12403               if (uv <= (UV) IV_MIN)
12404                 sv_setiv(sv, -(IV)uv);
12405               else
12406                 floatit = TRUE;
12407             } else
12408               floatit = TRUE;
12409         }
12410         if (floatit) {
12411             /* terminate the string */
12412             *d = '\0';
12413             nv = Atof(PL_tokenbuf);
12414             sv_setnv(sv, nv);
12415         }
12416
12417         if ( floatit
12418              ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12419             const char *const key = floatit ? "float" : "integer";
12420             const STRLEN keylen = floatit ? 5 : 7;
12421             sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12422                                 key, keylen, sv, NULL, NULL, 0);
12423         }
12424         break;
12425
12426     /* if it starts with a v, it could be a v-string */
12427     case 'v':
12428 vstring:
12429                 sv = newSV(5); /* preallocate storage space */
12430                 s = scan_vstring(s, PL_bufend, sv);
12431         break;
12432     }
12433
12434     /* make the op for the constant and return */
12435
12436     if (sv)
12437         lvalp->opval = newSVOP(OP_CONST, 0, sv);
12438     else
12439         lvalp->opval = NULL;
12440
12441     return (char *)s;
12442 }
12443
12444 STATIC char *
12445 S_scan_formline(pTHX_ register char *s)
12446 {
12447     dVAR;
12448     register char *eol;
12449     register char *t;
12450     SV * const stuff = newSVpvs("");
12451     bool needargs = FALSE;
12452     bool eofmt = FALSE;
12453 #ifdef PERL_MAD
12454     char *tokenstart = s;
12455     SV* savewhite = NULL;
12456
12457     if (PL_madskills) {
12458         savewhite = PL_thiswhite;
12459         PL_thiswhite = 0;
12460     }
12461 #endif
12462
12463     PERL_ARGS_ASSERT_SCAN_FORMLINE;
12464
12465     while (!needargs) {
12466         if (*s == '.') {
12467             t = s+1;
12468 #ifdef PERL_STRICT_CR
12469             while (SPACE_OR_TAB(*t))
12470                 t++;
12471 #else
12472             while (SPACE_OR_TAB(*t) || *t == '\r')
12473                 t++;
12474 #endif
12475             if (*t == '\n' || t == PL_bufend) {
12476                 eofmt = TRUE;
12477                 break;
12478             }
12479         }
12480         if (PL_in_eval && !PL_rsfp) {
12481             eol = (char *) memchr(s,'\n',PL_bufend-s);
12482             if (!eol++)
12483                 eol = PL_bufend;
12484         }
12485         else
12486             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12487         if (*s != '#') {
12488             for (t = s; t < eol; t++) {
12489                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12490                     needargs = FALSE;
12491                     goto enough;        /* ~~ must be first line in formline */
12492                 }
12493                 if (*t == '@' || *t == '^')
12494                     needargs = TRUE;
12495             }
12496             if (eol > s) {
12497                 sv_catpvn(stuff, s, eol-s);
12498 #ifndef PERL_STRICT_CR
12499                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12500                     char *end = SvPVX(stuff) + SvCUR(stuff);
12501                     end[-2] = '\n';
12502                     end[-1] = '\0';
12503                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12504                 }
12505 #endif
12506             }
12507             else
12508               break;
12509         }
12510         s = (char*)eol;
12511         if (PL_rsfp) {
12512 #ifdef PERL_MAD
12513             if (PL_madskills) {
12514                 if (PL_thistoken)
12515                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12516                 else
12517                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12518             }
12519 #endif
12520             s = filter_gets(PL_linestr, PL_rsfp, 0);
12521 #ifdef PERL_MAD
12522             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12523 #else
12524             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12525 #endif
12526             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12527             PL_last_lop = PL_last_uni = NULL;
12528             if (!s) {
12529                 s = PL_bufptr;
12530                 break;
12531             }
12532         }
12533         incline(s);
12534     }
12535   enough:
12536     if (SvCUR(stuff)) {
12537         PL_expect = XTERM;
12538         if (needargs) {
12539             PL_lex_state = LEX_NORMAL;
12540             start_force(PL_curforce);
12541             NEXTVAL_NEXTTOKE.ival = 0;
12542             force_next(',');
12543         }
12544         else
12545             PL_lex_state = LEX_FORMLINE;
12546         if (!IN_BYTES) {
12547             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12548                 SvUTF8_on(stuff);
12549             else if (PL_encoding)
12550                 sv_recode_to_utf8(stuff, PL_encoding);
12551         }
12552         start_force(PL_curforce);
12553         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12554         force_next(THING);
12555         start_force(PL_curforce);
12556         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12557         force_next(LSTOP);
12558     }
12559     else {
12560         SvREFCNT_dec(stuff);
12561         if (eofmt)
12562             PL_lex_formbrack = 0;
12563         PL_bufptr = s;
12564     }
12565 #ifdef PERL_MAD
12566     if (PL_madskills) {
12567         if (PL_thistoken)
12568             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12569         else
12570             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12571         PL_thiswhite = savewhite;
12572     }
12573 #endif
12574     return s;
12575 }
12576
12577 I32
12578 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12579 {
12580     dVAR;
12581     const I32 oldsavestack_ix = PL_savestack_ix;
12582     CV* const outsidecv = PL_compcv;
12583
12584     if (PL_compcv) {
12585         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12586     }
12587     SAVEI32(PL_subline);
12588     save_item(PL_subname);
12589     SAVESPTR(PL_compcv);
12590
12591     PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12592     CvFLAGS(PL_compcv) |= flags;
12593
12594     PL_subline = CopLINE(PL_curcop);
12595     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12596     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12597     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12598
12599     return oldsavestack_ix;
12600 }
12601
12602 #ifdef __SC__
12603 #pragma segment Perl_yylex
12604 #endif
12605 static int
12606 S_yywarn(pTHX_ const char *const s)
12607 {
12608     dVAR;
12609
12610     PERL_ARGS_ASSERT_YYWARN;
12611
12612     PL_in_eval |= EVAL_WARNONLY;
12613     yyerror(s);
12614     PL_in_eval &= ~EVAL_WARNONLY;
12615     return 0;
12616 }
12617
12618 int
12619 Perl_yyerror(pTHX_ const char *const s)
12620 {
12621     dVAR;
12622     const char *where = NULL;
12623     const char *context = NULL;
12624     int contlen = -1;
12625     SV *msg;
12626     int yychar  = PL_parser->yychar;
12627
12628     PERL_ARGS_ASSERT_YYERROR;
12629
12630     if (!yychar || (yychar == ';' && !PL_rsfp))
12631         where = "at EOF";
12632     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12633       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12634       PL_oldbufptr != PL_bufptr) {
12635         /*
12636                 Only for NetWare:
12637                 The code below is removed for NetWare because it abends/crashes on NetWare
12638                 when the script has error such as not having the closing quotes like:
12639                     if ($var eq "value)
12640                 Checking of white spaces is anyway done in NetWare code.
12641         */
12642 #ifndef NETWARE
12643         while (isSPACE(*PL_oldoldbufptr))
12644             PL_oldoldbufptr++;
12645 #endif
12646         context = PL_oldoldbufptr;
12647         contlen = PL_bufptr - PL_oldoldbufptr;
12648     }
12649     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12650       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12651         /*
12652                 Only for NetWare:
12653                 The code below is removed for NetWare because it abends/crashes on NetWare
12654                 when the script has error such as not having the closing quotes like:
12655                     if ($var eq "value)
12656                 Checking of white spaces is anyway done in NetWare code.
12657         */
12658 #ifndef NETWARE
12659         while (isSPACE(*PL_oldbufptr))
12660             PL_oldbufptr++;
12661 #endif
12662         context = PL_oldbufptr;
12663         contlen = PL_bufptr - PL_oldbufptr;
12664     }
12665     else if (yychar > 255)
12666         where = "next token ???";
12667     else if (yychar == -2) { /* YYEMPTY */
12668         if (PL_lex_state == LEX_NORMAL ||
12669            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12670             where = "at end of line";
12671         else if (PL_lex_inpat)
12672             where = "within pattern";
12673         else
12674             where = "within string";
12675     }
12676     else {
12677         SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12678         if (yychar < 32)
12679             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12680         else if (isPRINT_LC(yychar)) {
12681             const char string = yychar;
12682             sv_catpvn(where_sv, &string, 1);
12683         }
12684         else
12685             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12686         where = SvPVX_const(where_sv);
12687     }
12688     msg = sv_2mortal(newSVpv(s, 0));
12689     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12690         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12691     if (context)
12692         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12693     else
12694         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12695     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12696         Perl_sv_catpvf(aTHX_ msg,
12697         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12698                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12699         PL_multi_end = 0;
12700     }
12701     if (PL_in_eval & EVAL_WARNONLY) {
12702         if (ckWARN_d(WARN_SYNTAX))
12703             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12704     }
12705     else
12706         qerror(msg);
12707     if (PL_error_count >= 10) {
12708         if (PL_in_eval && SvCUR(ERRSV))
12709             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12710                        SVfARG(ERRSV), OutCopFILE(PL_curcop));
12711         else
12712             Perl_croak(aTHX_ "%s has too many errors.\n",
12713             OutCopFILE(PL_curcop));
12714     }
12715     PL_in_my = 0;
12716     PL_in_my_stash = NULL;
12717     return 0;
12718 }
12719 #ifdef __SC__
12720 #pragma segment Main
12721 #endif
12722
12723 STATIC char*
12724 S_swallow_bom(pTHX_ U8 *s)
12725 {
12726     dVAR;
12727     const STRLEN slen = SvCUR(PL_linestr);
12728
12729     PERL_ARGS_ASSERT_SWALLOW_BOM;
12730
12731     switch (s[0]) {
12732     case 0xFF:
12733         if (s[1] == 0xFE) {
12734             /* UTF-16 little-endian? (or UTF32-LE?) */
12735             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
12736                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12737 #ifndef PERL_NO_UTF16_FILTER
12738             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12739             s += 2;
12740         utf16le:
12741             if (PL_bufend > (char*)s) {
12742                 U8 *news;
12743                 I32 newlen;
12744
12745                 filter_add(utf16rev_textfilter, NULL);
12746                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12747                 utf16_to_utf8_reversed(s, news,
12748                                        PL_bufend - (char*)s - 1,
12749                                        &newlen);
12750                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12751 #ifdef PERL_MAD
12752                 s = (U8*)SvPVX(PL_linestr);
12753                 Copy(news, s, newlen, U8);
12754                 s[newlen] = '\0';
12755 #endif
12756                 Safefree(news);
12757                 SvUTF8_on(PL_linestr);
12758                 s = (U8*)SvPVX(PL_linestr);
12759 #ifdef PERL_MAD
12760                 /* FIXME - is this a general bug fix?  */
12761                 s[newlen] = '\0';
12762 #endif
12763                 PL_bufend = SvPVX(PL_linestr) + newlen;
12764             }
12765 #else
12766             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12767 #endif
12768         }
12769         break;
12770     case 0xFE:
12771         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
12772 #ifndef PERL_NO_UTF16_FILTER
12773             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12774             s += 2;
12775         utf16be:
12776             if (PL_bufend > (char *)s) {
12777                 U8 *news;
12778                 I32 newlen;
12779
12780                 filter_add(utf16_textfilter, NULL);
12781                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12782                 utf16_to_utf8(s, news,
12783                               PL_bufend - (char*)s,
12784                               &newlen);
12785                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12786                 Safefree(news);
12787                 SvUTF8_on(PL_linestr);
12788                 s = (U8*)SvPVX(PL_linestr);
12789                 PL_bufend = SvPVX(PL_linestr) + newlen;
12790             }
12791 #else
12792             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12793 #endif
12794         }
12795         break;
12796     case 0xEF:
12797         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12798             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12799             s += 3;                      /* UTF-8 */
12800         }
12801         break;
12802     case 0:
12803         if (slen > 3) {
12804              if (s[1] == 0) {
12805                   if (s[2] == 0xFE && s[3] == 0xFF) {
12806                        /* UTF-32 big-endian */
12807                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12808                   }
12809              }
12810              else if (s[2] == 0 && s[3] != 0) {
12811                   /* Leading bytes
12812                    * 00 xx 00 xx
12813                    * are a good indicator of UTF-16BE. */
12814                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12815                   goto utf16be;
12816              }
12817         }
12818 #ifdef EBCDIC
12819     case 0xDD:
12820         if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12821             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12822             s += 4;                      /* UTF-8 */
12823         }
12824         break;
12825 #endif
12826
12827     default:
12828          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12829                   /* Leading bytes
12830                    * xx 00 xx 00
12831                    * are a good indicator of UTF-16LE. */
12832               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12833               goto utf16le;
12834          }
12835     }
12836     return (char*)s;
12837 }
12838
12839
12840 #ifndef PERL_NO_UTF16_FILTER
12841 static I32
12842 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12843 {
12844     dVAR;
12845     const STRLEN old = SvCUR(sv);
12846     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12847     DEBUG_P(PerlIO_printf(Perl_debug_log,
12848                           "utf16_textfilter(%p): %d %d (%d)\n",
12849                           FPTR2DPTR(void *, utf16_textfilter),
12850                           idx, maxlen, (int) count));
12851     if (count) {
12852         U8* tmps;
12853         I32 newlen;
12854         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12855         Copy(SvPVX_const(sv), tmps, old, char);
12856         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12857                       SvCUR(sv) - old, &newlen);
12858         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12859     }
12860     DEBUG_P({sv_dump(sv);});
12861     return SvCUR(sv);
12862 }
12863
12864 static I32
12865 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12866 {
12867     dVAR;
12868     const STRLEN old = SvCUR(sv);
12869     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12870     DEBUG_P(PerlIO_printf(Perl_debug_log,
12871                           "utf16rev_textfilter(%p): %d %d (%d)\n",
12872                           FPTR2DPTR(void *, utf16rev_textfilter),
12873                           idx, maxlen, (int) count));
12874     if (count) {
12875         U8* tmps;
12876         I32 newlen;
12877         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12878         Copy(SvPVX_const(sv), tmps, old, char);
12879         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12880                       SvCUR(sv) - old, &newlen);
12881         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12882     }
12883     DEBUG_P({ sv_dump(sv); });
12884     return count;
12885 }
12886 #endif
12887
12888 /*
12889 Returns a pointer to the next character after the parsed
12890 vstring, as well as updating the passed in sv.
12891
12892 Function must be called like
12893
12894         sv = newSV(5);
12895         s = scan_vstring(s,e,sv);
12896
12897 where s and e are the start and end of the string.
12898 The sv should already be large enough to store the vstring
12899 passed in, for performance reasons.
12900
12901 */
12902
12903 char *
12904 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12905 {
12906     dVAR;
12907     const char *pos = s;
12908     const char *start = s;
12909
12910     PERL_ARGS_ASSERT_SCAN_VSTRING;
12911
12912     if (*pos == 'v') pos++;  /* get past 'v' */
12913     while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12914         pos++;
12915     if ( *pos != '.') {
12916         /* this may not be a v-string if followed by => */
12917         const char *next = pos;
12918         while (next < e && isSPACE(*next))
12919             ++next;
12920         if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12921             /* return string not v-string */
12922             sv_setpvn(sv,(char *)s,pos-s);
12923             return (char *)pos;
12924         }
12925     }
12926
12927     if (!isALPHA(*pos)) {
12928         U8 tmpbuf[UTF8_MAXBYTES+1];
12929
12930         if (*s == 'v')
12931             s++;  /* get past 'v' */
12932
12933         sv_setpvs(sv, "");
12934
12935         for (;;) {
12936             /* this is atoi() that tolerates underscores */
12937             U8 *tmpend;
12938             UV rev = 0;
12939             const char *end = pos;
12940             UV mult = 1;
12941             while (--end >= s) {
12942                 if (*end != '_') {
12943                     const UV orev = rev;
12944                     rev += (*end - '0') * mult;
12945                     mult *= 10;
12946                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12947                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12948                                     "Integer overflow in decimal number");
12949                 }
12950             }
12951 #ifdef EBCDIC
12952             if (rev > 0x7FFFFFFF)
12953                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12954 #endif
12955             /* Append native character for the rev point */
12956             tmpend = uvchr_to_utf8(tmpbuf, rev);
12957             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12958             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12959                  SvUTF8_on(sv);
12960             if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12961                  s = ++pos;
12962             else {
12963                  s = pos;
12964                  break;
12965             }
12966             while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12967                  pos++;
12968         }
12969         SvPOK_on(sv);
12970         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12971         SvRMAGICAL_on(sv);
12972     }
12973     return (char *)s;
12974 }
12975
12976 /*
12977  * Local variables:
12978  * c-indentation-style: bsd
12979  * c-basic-offset: 4
12980  * indent-tabs-mode: t
12981  * End:
12982  *
12983  * ex: set ts=8 sts=4 sw=4 noet:
12984  */