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