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