toke.c

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