toke.c

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