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