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