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