toke.c

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