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