toke.c

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