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