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