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