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