toke.c

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