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