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