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