toke.c

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