toke.c

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