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