toke.c

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