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