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 /* In variables named $^X, these are the legal values for X.
 128  * 1999-02-27 mjd-perl-patch@plover.com */
 129 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
 130
 131 /* On MacOS, respect nonbreaking spaces */
 132 #ifdef MACOS_TRADITIONAL
 133 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
 134 #else
 135 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
 136 #endif
 137
 138 /* LEX_* are values for PL_lex_state, the state of the lexer.
 139  * They are arranged oddly so that the guard on the switch statement
 140  * can get by with a single comparison (if the compiler is smart enough).
 141  */
 142
 143 /* #define LEX_NOTPARSING               11 is done in perl.h. */
 144
 145 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
 146 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
 147 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
 148 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
 149 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
 150
 151                                    /* at end of code, eg "$x" followed by:  */
 152 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
 153 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
 154
 155 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
 156                                         string or after \E, $foo, etc       */
 157 #define LEX_INTERPCONST          2 /* NOT USED */
 158 #define LEX_FORMLINE             1 /* expecting a format line               */
 159 #define LEX_KNOWNEXT             0 /* next token known; just return it      */
 160
 161
 162 #ifdef DEBUGGING
 163 static const char* const lex_state_names[] = {
 164     "KNOWNEXT",
 165     "FORMLINE",
 166     "INTERPCONST",
 167     "INTERPCONCAT",
 168     "INTERPENDMAYBE",
 169     "INTERPEND",
 170     "INTERPSTART",
 171     "INTERPPUSH",
 172     "INTERPCASEMOD",
 173     "INTERPNORMAL",
 174     "NORMAL"
 175 };
 176 #endif
 177
 178 #ifdef ff_next
 179 #undef ff_next
 180 #endif
 181
 182 #include "keywords.h"
 183
 184 /* CLINE is a macro that ensures PL_copline has a sane value */
 185
 186 #ifdef CLINE
 187 #undef CLINE
 188 #endif
 189 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 190
 191 #ifdef PERL_MAD
 192 #  define SKIPSPACE0(s) skipspace0(s)
 193 #  define SKIPSPACE1(s) skipspace1(s)
 194 #  define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
 195 #  define PEEKSPACE(s) skipspace2(s,0)
 196 #else
 197 #  define SKIPSPACE0(s) skipspace(s)
 198 #  define SKIPSPACE1(s) skipspace(s)
 199 #  define SKIPSPACE2(s,tsv) skipspace(s)
 200 #  define PEEKSPACE(s) skipspace(s)
 201 #endif
 202
 203 /*
 204  * Convenience functions to return different tokens and prime the
 205  * lexer for the next token.  They all take an argument.
 206  *
 207  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 208  * OPERATOR     : generic operator
 209  * AOPERATOR    : assignment operator
 210  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 211  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 212  * PREREF       : *EXPR where EXPR is not a simple identifier
 213  * TERM         : expression term
 214  * LOOPX        : loop exiting command (goto, last, dump, etc)
 215  * FTST         : file test operator
 216  * FUN0         : zero-argument function
 217  * FUN1         : not used, except for not, which isn't a UNIOP
 218  * BOop         : bitwise or or xor
 219  * BAop         : bitwise and
 220  * SHop         : shift operator
 221  * PWop         : power operator
 222  * PMop         : pattern-matching operator
 223  * Aop          : addition-level operator
 224  * Mop          : multiplication-level operator
 225  * Eop          : equality-testing operator
 226  * Rop          : relational operator <= != gt
 227  *
 228  * Also see LOP and lop() below.
 229  */
 230
 231 #ifdef DEBUGGING /* Serve -DT. */
 232 #   define REPORT(retval) tokereport((I32)retval, &pl_yylval)
 233 #else
 234 #   define REPORT(retval) (retval)
 235 #endif
 236
 237 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
 238 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
 239 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
 240 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
 241 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 242 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 243 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
 244 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 245 #define FTST(f)  return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 246 #define FUN0(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
 247 #define FUN1(f)  return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
 248 #define BOop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
 249 #define BAop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
 250 #define SHop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
 251 #define PWop(f)  return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
 252 #define PMop(f)  return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
 253 #define Aop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
 254 #define Mop(f)   return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
 255 #define Eop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
 256 #define Rop(f)   return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
 257
 258 /* This bit of chicanery makes a unary function followed by
 259  * a parenthesis into a function with one argument, highest precedence.
 260  * The UNIDOR macro is for unary functions that can be followed by the //
 261  * operator (such as C<shift // 0>).
 262  */
 263 #define UNI2(f,x) { \
 264         pl_yylval.ival = f; \
 265         PL_expect = x; \
 266         PL_bufptr = s; \
 267         PL_last_uni = PL_oldbufptr; \
 268         PL_last_lop_op = f; \
 269         if (*s == '(') \
 270             return REPORT( (int)FUNC1 ); \
 271         s = PEEKSPACE(s); \
 272         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
 273         }
 274 #define UNI(f)    UNI2(f,XTERM)
 275 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 276
 277 #define UNIBRACK(f) { \
 278         pl_yylval.ival = f; \
 279         PL_bufptr = s; \
 280         PL_last_uni = PL_oldbufptr; \
 281         if (*s == '(') \
 282             return REPORT( (int)FUNC1 ); \
 283         s = PEEKSPACE(s); \
 284         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
 285         }
 286
 287 /* grandfather return to old style */
 288 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 289
 290 #ifdef DEBUGGING
 291
 292 /* how to interpret the pl_yylval associated with the token */
 293 enum token_type {
 294     TOKENTYPE_NONE,
 295     TOKENTYPE_IVAL,
 296     TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
 297     TOKENTYPE_PVAL,
 298     TOKENTYPE_OPVAL,
 299     TOKENTYPE_GVVAL
 300 };
 301
 302 static struct debug_tokens {
 303     const int token;
 304     enum token_type type;
 305     const char *name;
 306 } const debug_tokens[] =
 307 {
 308     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
 309     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
 310     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
 311     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
 312     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
 313     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
 314     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
 315     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
 316     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
 317     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
 318     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
 319     { DO,               TOKENTYPE_NONE,         "DO" },
 320     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
 321     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
 322     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
 323     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
 324     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
 325     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
 326     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
 327     { FOR,              TOKENTYPE_IVAL,         "FOR" },
 328     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
 329     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
 330     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
 331     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
 332     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
 333     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
 334     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
 335     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
 336     { IF,               TOKENTYPE_IVAL,         "IF" },
 337     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
 338     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
 339     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
 340     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
 341     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
 342     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
 343     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
 344     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
 345     { MY,               TOKENTYPE_IVAL,         "MY" },
 346     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
 347     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
 348     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
 349     { OROP,             TOKENTYPE_IVAL,         "OROP" },
 350     { OROR,             TOKENTYPE_NONE,         "OROR" },
 351     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
 352     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
 353     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
 354     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
 355     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
 356     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
 357     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
 358     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
 359     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
 360     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
 361     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
 362     { SUB,              TOKENTYPE_NONE,         "SUB" },
 363     { THING,            TOKENTYPE_OPVAL,        "THING" },
 364     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
 365     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
 366     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
 367     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
 368     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
 369     { USE,              TOKENTYPE_IVAL,         "USE" },
 370     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
 371     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
 372     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
 373     { YADAYADA,         TOKENTYPE_IVAL,         "YADAYADA" },
 374     { 0,                TOKENTYPE_NONE,         NULL }
 375 };
 376
 377 /* dump the returned token in rv, plus any optional arg in pl_yylval */
 378
 379 STATIC int
 380 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
 381 {
 382     dVAR;
 383
 384     PERL_ARGS_ASSERT_TOKEREPORT;
 385
 386     if (DEBUG_T_TEST) {
 387         const char *name = NULL;
 388         enum token_type type = TOKENTYPE_NONE;
 389         const struct debug_tokens *p;
 390         SV* const report = newSVpvs("<== ");
 391
 392         for (p = debug_tokens; p->token; p++) {
 393             if (p->token == (int)rv) {
 394                 name = p->name;
 395                 type = p->type;
 396                 break;
 397             }
 398         }
 399         if (name)
 400             Perl_sv_catpv(aTHX_ report, name);
 401         else if ((char)rv > ' ' && (char)rv < '~')
 402             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
 403         else if (!rv)
 404             sv_catpvs(report, "EOF");
 405         else
 406             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
 407         switch (type) {
 408         case TOKENTYPE_NONE:
 409         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
 410             break;
 411         case TOKENTYPE_IVAL:
 412             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
 413             break;
 414         case TOKENTYPE_OPNUM:
 415             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
 416                                     PL_op_name[lvalp->ival]);
 417             break;
 418         case TOKENTYPE_PVAL:
 419             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
 420             break;
 421         case TOKENTYPE_OPVAL:
 422             if (lvalp->opval) {
 423                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 424                                     PL_op_name[lvalp->opval->op_type]);
 425                 if (lvalp->opval->op_type == OP_CONST) {
 426                     Perl_sv_catpvf(aTHX_ report, " %s",
 427                         SvPEEK(cSVOPx_sv(lvalp->opval)));
 428                 }
 429
 430             }
 431             else
 432                 sv_catpvs(report, "(opval=null)");
 433             break;
 434         }
 435         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
 436     };
 437     return (int)rv;
 438 }
 439
 440
 441 /* print the buffer with suitable escapes */
 442
 443 STATIC void
 444 S_printbuf(pTHX_ const char *const fmt, const char *const s)
 445 {
 446     SV* const tmp = newSVpvs("");
 447
 448     PERL_ARGS_ASSERT_PRINTBUF;
 449
 450     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
 451     SvREFCNT_dec(tmp);
 452 }
 453
 454 #endif
 455
 456 /*
 457  * S_ao
 458  *
 459  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 460  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 461  */
 462
 463 STATIC int
 464 S_ao(pTHX_ int toketype)
 465 {
 466     dVAR;
 467     if (*PL_bufptr == '=') {
 468         PL_bufptr++;
 469         if (toketype == ANDAND)
 470             pl_yylval.ival = OP_ANDASSIGN;
 471         else if (toketype == OROR)
 472             pl_yylval.ival = OP_ORASSIGN;
 473         else if (toketype == DORDOR)
 474             pl_yylval.ival = OP_DORASSIGN;
 475         toketype = ASSIGNOP;
 476     }
 477     return toketype;
 478 }
 479
 480 /*
 481  * S_no_op
 482  * When Perl expects an operator and finds something else, no_op
 483  * prints the warning.  It always prints "<something> found where
 484  * operator expected.  It prints "Missing semicolon on previous line?"
 485  * if the surprise occurs at the start of the line.  "do you need to
 486  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 487  * where the compiler doesn't know if foo is a method call or a function.
 488  * It prints "Missing operator before end of line" if there's nothing
 489  * after the missing operator, or "... before <...>" if there is something
 490  * after the missing operator.
 491  */
 492
 493 STATIC void
 494 S_no_op(pTHX_ const char *const what, char *s)
 495 {
 496     dVAR;
 497     char * const oldbp = PL_bufptr;
 498     const bool is_first = (PL_oldbufptr == PL_linestart);
 499
 500     PERL_ARGS_ASSERT_NO_OP;
 501
 502     if (!s)
 503         s = oldbp;
 504     else
 505         PL_bufptr = s;
 506     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 507     if (ckWARN_d(WARN_SYNTAX)) {
 508         if (is_first)
 509             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 510                     "\t(Missing semicolon on previous line?)\n");
 511         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 512             const char *t;
 513             for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
 514                 NOOP;
 515             if (t < PL_bufptr && isSPACE(*t))
 516                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 517                         "\t(Do you need to predeclare %.*s?)\n",
 518                     (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 519         }
 520         else {
 521             assert(s >= oldbp);
 522             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 523                     "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 524         }
 525     }
 526     PL_bufptr = oldbp;
 527 }
 528
 529 /*
 530  * S_missingterm
 531  * Complain about missing quote/regexp/heredoc terminator.
 532  * If it's called with NULL then it cauterizes the line buffer.
 533  * If we're in a delimited string and the delimiter is a control
 534  * character, it's reformatted into a two-char sequence like ^C.
 535  * This is fatal.
 536  */
 537
 538 STATIC void
 539 S_missingterm(pTHX_ char *s)
 540 {
 541     dVAR;
 542     char tmpbuf[3];
 543     char q;
 544     if (s) {
 545         char * const nl = strrchr(s,'\n');
 546         if (nl)
 547             *nl = '\0';
 548     }
 549     else if (isCNTRL(PL_multi_close)) {
 550         *tmpbuf = '^';
 551         tmpbuf[1] = (char)toCTRL(PL_multi_close);
 552         tmpbuf[2] = '\0';
 553         s = tmpbuf;
 554     }
 555     else {
 556         *tmpbuf = (char)PL_multi_close;
 557         tmpbuf[1] = '\0';
 558         s = tmpbuf;
 559     }
 560     q = strchr(s,'"') ? '\'' : '"';
 561     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 562 }
 563
 564 #define FEATURE_IS_ENABLED(name)                                        \
 565         ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
 566             && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 567 /* The longest string we pass in.  */
 568 #define MAX_FEATURE_LEN (sizeof("switch")-1)
 569
 570 /*
 571  * S_feature_is_enabled
 572  * Check whether the named feature is enabled.
 573  */
 574 STATIC bool
 575 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
 576 {
 577     dVAR;
 578     HV * const hinthv = GvHV(PL_hintgv);
 579     char he_name[8 + MAX_FEATURE_LEN] = "feature_";
 580
 581     PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
 582
 583     assert(namelen <= MAX_FEATURE_LEN);
 584     memcpy(&he_name[8], name, namelen);
 585
 586     return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 587 }
 588
 589 /*
 590  * Perl_deprecate
 591  */
 592
 593 void
 594 Perl_deprecate(pTHX_ const char *const s)
 595 {
 596     PERL_ARGS_ASSERT_DEPRECATE;
 597
 598     if (ckWARN(WARN_DEPRECATED))
 599         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 600 }
 601
 602 void
 603 Perl_deprecate_old(pTHX_ const char *const s)
 604 {
 605     /* This function should NOT be called for any new deprecated warnings */
 606     /* Use Perl_deprecate instead                                         */
 607     /*                                                                    */
 608     /* It is here to maintain backward compatibility with the pre-5.8     */
 609     /* warnings category hierarchy. The "deprecated" category used to     */
 610     /* live under the "syntax" category. It is now a top-level category   */
 611     /* in its own right.                                                  */
 612
 613     PERL_ARGS_ASSERT_DEPRECATE_OLD;
 614
 615     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 616         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 617                         "Use of %s is deprecated", s);
 618 }
 619
 620 /*
 621  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 622  * utf16-to-utf8-reversed.
 623  */
 624
 625 #ifdef PERL_CR_FILTER
 626 static void
 627 strip_return(SV *sv)
 628 {
 629     register const char *s = SvPVX_const(sv);
 630     register const char * const e = s + SvCUR(sv);
 631
 632     PERL_ARGS_ASSERT_STRIP_RETURN;
 633
 634     /* outer loop optimized to do nothing if there are no CR-LFs */
 635     while (s < e) {
 636         if (*s++ == '\r' && *s == '\n') {
 637             /* hit a CR-LF, need to copy the rest */
 638             register char *d = s - 1;
 639             *d++ = *s++;
 640             while (s < e) {
 641                 if (*s == '\r' && s[1] == '\n')
 642                     s++;
 643                 *d++ = *s++;
 644             }
 645             SvCUR(sv) -= s - d;
 646             return;
 647         }
 648     }
 649 }
 650
 651 STATIC I32
 652 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 653 {
 654     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 655     if (count > 0 && !maxlen)
 656         strip_return(sv);
 657     return count;
 658 }
 659 #endif
 660
 661
 662
 663 /*
 664  * Perl_lex_start
 665  *
 666  * Create a parser object and initialise its parser and lexer fields
 667  *
 668  * rsfp       is the opened file handle to read from (if any),
 669  *
 670  * line       holds any initial content already read from the file (or in
 671  *            the case of no file, such as an eval, the whole contents);
 672  *
 673  * new_filter indicates that this is a new file and it shouldn't inherit
 674  *            the filters from the current parser (ie require).
 675  */
 676
 677 void
 678 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
 679 {
 680     dVAR;
 681     const char *s = NULL;
 682     STRLEN len;
 683     yy_parser *parser, *oparser;
 684
 685     /* create and initialise a parser */
 686
 687     Newxz(parser, 1, yy_parser);
 688     parser->old_parser = oparser = PL_parser;
 689     PL_parser = parser;
 690
 691     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 692     parser->ps = parser->stack;
 693     parser->stack_size = YYINITDEPTH;
 694
 695     parser->stack->state = 0;
 696     parser->yyerrstatus = 0;
 697     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
 698
 699     /* on scope exit, free this parser and restore any outer one */
 700     SAVEPARSER(parser);
 701     parser->saved_curcop = PL_curcop;
 702
 703     /* initialise lexer state */
 704
 705 #ifdef PERL_MAD
 706     parser->curforce = -1;
 707 #else
 708     parser->nexttoke = 0;
 709 #endif
 710     parser->error_count = oparser ? oparser->error_count : 0;
 711     parser->copline = NOLINE;
 712     parser->lex_state = LEX_NORMAL;
 713     parser->expect = XSTATE;
 714     parser->rsfp = rsfp;
 715     parser->rsfp_filters = (new_filter || !oparser) ? newAV()
 716                 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
 717
 718     Newx(parser->lex_brackstack, 120, char);
 719     Newx(parser->lex_casestack, 12, char);
 720     *parser->lex_casestack = '\0';
 721
 722     if (line) {
 723         s = SvPV_const(line, len);
 724     } else {
 725         len = 0;
 726     }
 727
 728     if (!len) {
 729         parser->linestr = newSVpvs("\n;");
 730     } else if (SvREADONLY(line) || s[len-1] != ';') {
 731         parser->linestr = newSVsv(line);
 732         if (s[len-1] != ';')
 733             sv_catpvs(parser->linestr, "\n;");
 734     } else {
 735         SvTEMP_off(line);
 736         SvREFCNT_inc_simple_void_NN(line);
 737         parser->linestr = line;
 738     }
 739     parser->oldoldbufptr =
 740         parser->oldbufptr =
 741         parser->bufptr =
 742         parser->linestart = SvPVX(parser->linestr);
 743     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
 744     parser->last_lop = parser->last_uni = NULL;
 745 }
 746
 747
 748 /* delete a parser object */
 749
 750 void
 751 Perl_parser_free(pTHX_  const yy_parser *parser)
 752 {
 753     PERL_ARGS_ASSERT_PARSER_FREE;
 754
 755     PL_curcop = parser->saved_curcop;
 756     SvREFCNT_dec(parser->linestr);
 757
 758     if (parser->rsfp == PerlIO_stdin())
 759         PerlIO_clearerr(parser->rsfp);
 760     else if (parser->rsfp && (!parser->old_parser ||
 761                 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
 762         PerlIO_close(parser->rsfp);
 763     SvREFCNT_dec(parser->rsfp_filters);
 764
 765     Safefree(parser->stack);
 766     Safefree(parser->lex_brackstack);
 767     Safefree(parser->lex_casestack);
 768     PL_parser = parser->old_parser;
 769     Safefree(parser);
 770 }
 771
 772
 773 /*
 774  * Perl_lex_end
 775  * Finalizer for lexing operations.  Must be called when the parser is
 776  * done with the lexer.
 777  */
 778
 779 void
 780 Perl_lex_end(pTHX)
 781 {
 782     dVAR;
 783     PL_doextract = FALSE;
 784 }
 785
 786 /*
 787  * S_incline
 788  * This subroutine has nothing to do with tilting, whether at windmills
 789  * or pinball tables.  Its name is short for "increment line".  It
 790  * increments the current line number in CopLINE(PL_curcop) and checks
 791  * to see whether the line starts with a comment of the form
 792  *    # line 500 "foo.pm"
 793  * If so, it sets the current line number and file to the values in the comment.
 794  */
 795
 796 STATIC void
 797 S_incline(pTHX_ const char *s)
 798 {
 799     dVAR;
 800     const char *t;
 801     const char *n;
 802     const char *e;
 803
 804     PERL_ARGS_ASSERT_INCLINE;
 805
 806     CopLINE_inc(PL_curcop);
 807     if (*s++ != '#')
 808         return;
 809     while (SPACE_OR_TAB(*s))
 810         s++;
 811     if (strnEQ(s, "line", 4))
 812         s += 4;
 813     else
 814         return;
 815     if (SPACE_OR_TAB(*s))
 816         s++;
 817     else
 818         return;
 819     while (SPACE_OR_TAB(*s))
 820         s++;
 821     if (!isDIGIT(*s))
 822         return;
 823
 824     n = s;
 825     while (isDIGIT(*s))
 826         s++;
 827     if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
 828         return;
 829     while (SPACE_OR_TAB(*s))
 830         s++;
 831     if (*s == '"' && (t = strchr(s+1, '"'))) {
 832         s++;
 833         e = t + 1;
 834     }
 835     else {
 836         t = s;
 837         while (!isSPACE(*t))
 838             t++;
 839         e = t;
 840     }
 841     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 842         e++;
 843     if (*e != '\n' && *e != '\0')
 844         return;         /* false alarm */
 845
 846     if (t - s > 0) {
 847         const STRLEN len = t - s;
 848 #ifndef USE_ITHREADS
 849         SV *const temp_sv = CopFILESV(PL_curcop);
 850         const char *cf;
 851         STRLEN tmplen;
 852
 853         if (temp_sv) {
 854             cf = SvPVX(temp_sv);
 855             tmplen = SvCUR(temp_sv);
 856         } else {
 857             cf = NULL;
 858             tmplen = 0;
 859         }
 860
 861         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 862             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 863              * to *{"::_<newfilename"} */
 864             /* However, the long form of evals is only turned on by the
 865                debugger - usually they're "(eval %lu)" */
 866             char smallbuf[128];
 867             char *tmpbuf;
 868             GV **gvp;
 869             STRLEN tmplen2 = len;
 870             if (tmplen + 2 <= sizeof smallbuf)
 871                 tmpbuf = smallbuf;
 872             else
 873                 Newx(tmpbuf, tmplen + 2, char);
 874             tmpbuf[0] = '_';
 875             tmpbuf[1] = '<';
 876             memcpy(tmpbuf + 2, cf, tmplen);
 877             tmplen += 2;
 878             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 879             if (gvp) {
 880                 char *tmpbuf2;
 881                 GV *gv2;
 882
 883                 if (tmplen2 + 2 <= sizeof smallbuf)
 884                     tmpbuf2 = smallbuf;
 885                 else
 886                     Newx(tmpbuf2, tmplen2 + 2, char);
 887
 888                 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
 889                     /* Either they malloc'd it, or we malloc'd it,
 890                        so no prefix is present in ours.  */
 891                     tmpbuf2[0] = '_';
 892                     tmpbuf2[1] = '<';
 893                 }
 894
 895                 memcpy(tmpbuf2 + 2, s, tmplen2);
 896                 tmplen2 += 2;
 897
 898                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 899                 if (!isGV(gv2)) {
 900                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 901                     /* adjust ${"::_<newfilename"} to store the new file name */
 902                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 903                     GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
 904                     GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
 905                 }
 906
 907                 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
 908             }
 909             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 910         }
 911 #endif
 912         CopFILE_free(PL_curcop);
 913         CopFILE_setn(PL_curcop, s, len);
 914     }
 915     CopLINE_set(PL_curcop, atoi(n)-1);
 916 }
 917
 918 #ifdef PERL_MAD
 919 /* skip space before PL_thistoken */
 920
 921 STATIC char *
 922 S_skipspace0(pTHX_ register char *s)
 923 {
 924     PERL_ARGS_ASSERT_SKIPSPACE0;
 925
 926     s = skipspace(s);
 927     if (!PL_madskills)
 928         return s;
 929     if (PL_skipwhite) {
 930         if (!PL_thiswhite)
 931             PL_thiswhite = newSVpvs("");
 932         sv_catsv(PL_thiswhite, PL_skipwhite);
 933         sv_free(PL_skipwhite);
 934         PL_skipwhite = 0;
 935     }
 936     PL_realtokenstart = s - SvPVX(PL_linestr);
 937     return s;
 938 }
 939
 940 /* skip space after PL_thistoken */
 941
 942 STATIC char *
 943 S_skipspace1(pTHX_ register char *s)
 944 {
 945     const char *start = s;
 946     I32 startoff = start - SvPVX(PL_linestr);
 947
 948     PERL_ARGS_ASSERT_SKIPSPACE1;
 949
 950     s = skipspace(s);
 951     if (!PL_madskills)
 952         return s;
 953     start = SvPVX(PL_linestr) + startoff;
 954     if (!PL_thistoken && PL_realtokenstart >= 0) {
 955         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 956         PL_thistoken = newSVpvn(tstart, start - tstart);
 957     }
 958     PL_realtokenstart = -1;
 959     if (PL_skipwhite) {
 960         if (!PL_nextwhite)
 961             PL_nextwhite = newSVpvs("");
 962         sv_catsv(PL_nextwhite, PL_skipwhite);
 963         sv_free(PL_skipwhite);
 964         PL_skipwhite = 0;
 965     }
 966     return s;
 967 }
 968
 969 STATIC char *
 970 S_skipspace2(pTHX_ register char *s, SV **svp)
 971 {
 972     char *start;
 973     const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 974     const I32 startoff = s - SvPVX(PL_linestr);
 975
 976     PERL_ARGS_ASSERT_SKIPSPACE2;
 977
 978     s = skipspace(s);
 979     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 980     if (!PL_madskills || !svp)
 981         return s;
 982     start = SvPVX(PL_linestr) + startoff;
 983     if (!PL_thistoken && PL_realtokenstart >= 0) {
 984         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 985         PL_thistoken = newSVpvn(tstart, start - tstart);
 986         PL_realtokenstart = -1;
 987     }
 988     if (PL_skipwhite) {
 989         if (!*svp)
 990             *svp = newSVpvs("");
 991         sv_setsv(*svp, PL_skipwhite);
 992         sv_free(PL_skipwhite);
 993         PL_skipwhite = 0;
 994     }
 995
 996     return s;
 997 }
 998 #endif
 999
1000 STATIC void
1001 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1002 {
1003     AV *av = CopFILEAVx(PL_curcop);
1004     if (av) {
1005         SV * const sv = newSV_type(SVt_PVMG);
1006         if (orig_sv)
1007             sv_setsv(sv, orig_sv);
1008         else
1009             sv_setpvn(sv, buf, len);
1010         (void)SvIOK_on(sv);
1011         SvIV_set(sv, 0);
1012         av_store(av, (I32)CopLINE(PL_curcop), sv);
1013     }
1014 }
1015
1016 /*
1017  * S_skipspace
1018  * Called to gobble the appropriate amount and type of whitespace.
1019  * Skips comments as well.
1020  */
1021
1022 STATIC char *
1023 S_skipspace(pTHX_ register char *s)
1024 {
1025     dVAR;
1026 #ifdef PERL_MAD
1027     int curoff;
1028     int startoff = s - SvPVX(PL_linestr);
1029
1030     PERL_ARGS_ASSERT_SKIPSPACE;
1031
1032     if (PL_skipwhite) {
1033         sv_free(PL_skipwhite);
1034         PL_skipwhite = 0;
1035     }
1036 #endif
1037     PERL_ARGS_ASSERT_SKIPSPACE;
1038
1039     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1040         while (s < PL_bufend && SPACE_OR_TAB(*s))
1041             s++;
1042 #ifdef PERL_MAD
1043         goto done;
1044 #else
1045         return s;
1046 #endif
1047     }
1048     for (;;) {
1049         STRLEN prevlen;
1050         SSize_t oldprevlen, oldoldprevlen;
1051         SSize_t oldloplen = 0, oldunilen = 0;
1052         while (s < PL_bufend && isSPACE(*s)) {
1053             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1054                 incline(s);
1055         }
1056
1057         /* comment */
1058         if (s < PL_bufend && *s == '#') {
1059             while (s < PL_bufend && *s != '\n')
1060                 s++;
1061             if (s < PL_bufend) {
1062                 s++;
1063                 if (PL_in_eval && !PL_rsfp) {
1064                     incline(s);
1065                     continue;
1066                 }
1067             }
1068         }
1069
1070         /* only continue to recharge the buffer if we're at the end
1071          * of the buffer, we're not reading from a source filter, and
1072          * we're in normal lexing mode
1073          */
1074         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1075                 PL_lex_state == LEX_FORMLINE)
1076 #ifdef PERL_MAD
1077             goto done;
1078 #else
1079             return s;
1080 #endif
1081
1082         /* try to recharge the buffer */
1083 #ifdef PERL_MAD
1084         curoff = s - SvPVX(PL_linestr);
1085 #endif
1086
1087         if ((s = filter_gets(PL_linestr, PL_rsfp,
1088                              (prevlen = SvCUR(PL_linestr)))) == NULL)
1089         {
1090 #ifdef PERL_MAD
1091             if (PL_madskills && curoff != startoff) {
1092                 if (!PL_skipwhite)
1093                     PL_skipwhite = newSVpvs("");
1094                 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1095                                         curoff - startoff);
1096             }
1097
1098             /* mustn't throw out old stuff yet if madpropping */
1099             SvCUR(PL_linestr) = curoff;
1100             s = SvPVX(PL_linestr) + curoff;
1101             *s = 0;
1102             if (curoff && s[-1] == '\n')
1103                 s[-1] = ' ';
1104 #endif
1105
1106             /* end of file.  Add on the -p or -n magic */
1107             /* XXX these shouldn't really be added here, can't set PL_faketokens */
1108             if (PL_minus_p) {
1109 #ifdef PERL_MAD
1110                 sv_catpvs(PL_linestr,
1111                          ";}continue{print or die qq(-p destination: $!\\n);}");
1112 #else
1113                 sv_setpvs(PL_linestr,
1114                          ";}continue{print or die qq(-p destination: $!\\n);}");
1115 #endif
1116                 PL_minus_n = PL_minus_p = 0;
1117             }
1118             else if (PL_minus_n) {
1119 #ifdef PERL_MAD
1120                 sv_catpvs(PL_linestr, ";}");
1121 #else
1122                 sv_setpvs(PL_linestr, ";}");
1123 #endif
1124                 PL_minus_n = 0;
1125             }
1126             else
1127 #ifdef PERL_MAD
1128                 sv_catpvs(PL_linestr,";");
1129 #else
1130                 sv_setpvs(PL_linestr,";");
1131 #endif
1132
1133             /* reset variables for next time we lex */
1134             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1135                 = SvPVX(PL_linestr)
1136 #ifdef PERL_MAD
1137                 + curoff
1138 #endif
1139                 ;
1140             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1141             PL_last_lop = PL_last_uni = NULL;
1142
1143             /* Close the filehandle.  Could be from
1144              * STDIN, or a regular file.  If we were reading code from
1145              * STDIN (because the commandline held no -e or filename)
1146              * then we don't close it, we reset it so the code can
1147              * read from STDIN too.
1148              */
1149
1150             if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1151                 PerlIO_clearerr(PL_rsfp);
1152             else
1153                 (void)PerlIO_close(PL_rsfp);
1154             PL_rsfp = NULL;
1155             return s;
1156         }
1157
1158         /* not at end of file, so we only read another line */
1159         /* make corresponding updates to old pointers, for yyerror() */
1160         oldprevlen = PL_oldbufptr - PL_bufend;
1161         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1162         if (PL_last_uni)
1163             oldunilen = PL_last_uni - PL_bufend;
1164         if (PL_last_lop)
1165             oldloplen = PL_last_lop - PL_bufend;
1166         PL_linestart = PL_bufptr = s + prevlen;
1167         PL_bufend = s + SvCUR(PL_linestr);
1168         s = PL_bufptr;
1169         PL_oldbufptr = s + oldprevlen;
1170         PL_oldoldbufptr = s + oldoldprevlen;
1171         if (PL_last_uni)
1172             PL_last_uni = s + oldunilen;
1173         if (PL_last_lop)
1174             PL_last_lop = s + oldloplen;
1175         incline(s);
1176
1177         /* debugger active and we're not compiling the debugger code,
1178          * so store the line into the debugger's array of lines
1179          */
1180         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1181             update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1182     }
1183
1184 #ifdef PERL_MAD
1185   done:
1186     if (PL_madskills) {
1187         if (!PL_skipwhite)
1188             PL_skipwhite = newSVpvs("");
1189         curoff = s - SvPVX(PL_linestr);
1190         if (curoff - startoff)
1191             sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1192                                 curoff - startoff);
1193     }
1194     return s;
1195 #endif
1196 }
1197
1198 /*
1199  * S_check_uni
1200  * Check the unary operators to ensure there's no ambiguity in how they're
1201  * used.  An ambiguous piece of code would be:
1202  *     rand + 5
1203  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1204  * the +5 is its argument.
1205  */
1206
1207 STATIC void
1208 S_check_uni(pTHX)
1209 {
1210     dVAR;
1211     const char *s;
1212     const char *t;
1213
1214     if (PL_oldoldbufptr != PL_last_uni)
1215         return;
1216     while (isSPACE(*PL_last_uni))
1217         PL_last_uni++;
1218     s = PL_last_uni;
1219     while (isALNUM_lazy_if(s,UTF) || *s == '-')
1220         s++;
1221     if ((t = strchr(s, '(')) && t < PL_bufptr)
1222         return;
1223
1224     if (ckWARN_d(WARN_AMBIGUOUS)){
1225         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1226                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1227                    (int)(s - PL_last_uni), PL_last_uni);
1228     }
1229 }
1230
1231 /*
1232  * LOP : macro to build a list operator.  Its behaviour has been replaced
1233  * with a subroutine, S_lop() for which LOP is just another name.
1234  */
1235
1236 #define LOP(f,x) return lop(f,x,s)
1237
1238 /*
1239  * S_lop
1240  * Build a list operator (or something that might be one).  The rules:
1241  *  - if we have a next token, then it's a list operator [why?]
1242  *  - if the next thing is an opening paren, then it's a function
1243  *  - else it's a list operator
1244  */
1245
1246 STATIC I32
1247 S_lop(pTHX_ I32 f, int x, char *s)
1248 {
1249     dVAR;
1250
1251     PERL_ARGS_ASSERT_LOP;
1252
1253     pl_yylval.ival = f;
1254     CLINE;
1255     PL_expect = x;
1256     PL_bufptr = s;
1257     PL_last_lop = PL_oldbufptr;
1258     PL_last_lop_op = (OPCODE)f;
1259 #ifdef PERL_MAD
1260     if (PL_lasttoke)
1261         return REPORT(LSTOP);
1262 #else
1263     if (PL_nexttoke)
1264         return REPORT(LSTOP);
1265 #endif
1266     if (*s == '(')
1267         return REPORT(FUNC);
1268     s = PEEKSPACE(s);
1269     if (*s == '(')
1270         return REPORT(FUNC);
1271     else
1272         return REPORT(LSTOP);
1273 }
1274
1275 #ifdef PERL_MAD
1276  /*
1277  * S_start_force
1278  * Sets up for an eventual force_next().  start_force(0) basically does
1279  * an unshift, while start_force(-1) does a push.  yylex removes items
1280  * on the "pop" end.
1281  */
1282
1283 STATIC void
1284 S_start_force(pTHX_ int where)
1285 {
1286     int i;
1287
1288     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
1289         where = PL_lasttoke;
1290     assert(PL_curforce < 0 || PL_curforce == where);
1291     if (PL_curforce != where) {
1292         for (i = PL_lasttoke; i > where; --i) {
1293             PL_nexttoke[i] = PL_nexttoke[i-1];
1294         }
1295         PL_lasttoke++;
1296     }
1297     if (PL_curforce < 0)        /* in case of duplicate start_force() */
1298         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1299     PL_curforce = where;
1300     if (PL_nextwhite) {
1301         if (PL_madskills)
1302             curmad('^', newSVpvs(""));
1303         CURMAD('_', PL_nextwhite);
1304     }
1305 }
1306
1307 STATIC void
1308 S_curmad(pTHX_ char slot, SV *sv)
1309 {
1310     MADPROP **where;
1311
1312     if (!sv)
1313         return;
1314     if (PL_curforce < 0)
1315         where = &PL_thismad;
1316     else
1317         where = &PL_nexttoke[PL_curforce].next_mad;
1318
1319     if (PL_faketokens)
1320         sv_setpvs(sv, "");
1321     else {
1322         if (!IN_BYTES) {
1323             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1324                 SvUTF8_on(sv);
1325             else if (PL_encoding) {
1326                 sv_recode_to_utf8(sv, PL_encoding);
1327             }
1328         }
1329     }
1330
1331     /* keep a slot open for the head of the list? */
1332     if (slot != '_' && *where && (*where)->mad_key == '^') {
1333         (*where)->mad_key = slot;
1334         sv_free(MUTABLE_SV(((*where)->mad_val)));
1335         (*where)->mad_val = (void*)sv;
1336     }
1337     else
1338         addmad(newMADsv(slot, sv), where, 0);
1339 }
1340 #else
1341 #  define start_force(where)    NOOP
1342 #  define curmad(slot, sv)      NOOP
1343 #endif
1344
1345 /*
1346  * S_force_next
1347  * When the lexer realizes it knows the next token (for instance,
1348  * it is reordering tokens for the parser) then it can call S_force_next
1349  * to know what token to return the next time the lexer is called.  Caller
1350  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1351  * and possibly PL_expect to ensure the lexer handles the token correctly.
1352  */
1353
1354 STATIC void
1355 S_force_next(pTHX_ I32 type)
1356 {
1357     dVAR;
1358 #ifdef DEBUGGING
1359     if (DEBUG_T_TEST) {
1360         PerlIO_printf(Perl_debug_log, "### forced token:\n");
1361         tokereport(type, &NEXTVAL_NEXTTOKE);
1362     }
1363 #endif
1364 #ifdef PERL_MAD
1365     if (PL_curforce < 0)
1366         start_force(PL_lasttoke);
1367     PL_nexttoke[PL_curforce].next_type = type;
1368     if (PL_lex_state != LEX_KNOWNEXT)
1369         PL_lex_defer = PL_lex_state;
1370     PL_lex_state = LEX_KNOWNEXT;
1371     PL_lex_expect = PL_expect;
1372     PL_curforce = -1;
1373 #else
1374     PL_nexttype[PL_nexttoke] = type;
1375     PL_nexttoke++;
1376     if (PL_lex_state != LEX_KNOWNEXT) {
1377         PL_lex_defer = PL_lex_state;
1378         PL_lex_expect = PL_expect;
1379         PL_lex_state = LEX_KNOWNEXT;
1380     }
1381 #endif
1382 }
1383
1384 STATIC SV *
1385 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1386 {
1387     dVAR;
1388     SV * const sv = newSVpvn_utf8(start, len,
1389                                   UTF && !IN_BYTES
1390                                   && is_utf8_string((const U8*)start, len));
1391     return sv;
1392 }
1393
1394 /*
1395  * S_force_word
1396  * When the lexer knows the next thing is a word (for instance, it has
1397  * just seen -> and it knows that the next char is a word char, then
1398  * it calls S_force_word to stick the next word into the PL_nexttoke/val
1399  * lookahead.
1400  *
1401  * Arguments:
1402  *   char *start : buffer position (must be within PL_linestr)
1403  *   int token   : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1404  *   int check_keyword : if true, Perl checks to make sure the word isn't
1405  *       a keyword (do this if the word is a label, e.g. goto FOO)
1406  *   int allow_pack : if true, : characters will also be allowed (require,
1407  *       use, etc. do this)
1408  *   int allow_initial_tick : used by the "sub" lexer only.
1409  */
1410
1411 STATIC char *
1412 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1413 {
1414     dVAR;
1415     register char *s;
1416     STRLEN len;
1417
1418     PERL_ARGS_ASSERT_FORCE_WORD;
1419
1420     start = SKIPSPACE1(start);
1421     s = start;
1422     if (isIDFIRST_lazy_if(s,UTF) ||
1423         (allow_pack && *s == ':') ||
1424         (allow_initial_tick && *s == '\'') )
1425     {
1426         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1427         if (check_keyword && keyword(PL_tokenbuf, len, 0))
1428             return start;
1429         start_force(PL_curforce);
1430         if (PL_madskills)
1431             curmad('X', newSVpvn(start,s-start));
1432         if (token == METHOD) {
1433             s = SKIPSPACE1(s);
1434             if (*s == '(')
1435                 PL_expect = XTERM;
1436             else {
1437                 PL_expect = XOPERATOR;
1438             }
1439         }
1440         if (PL_madskills)
1441             curmad('g', newSVpvs( "forced" ));
1442         NEXTVAL_NEXTTOKE.opval
1443             = (OP*)newSVOP(OP_CONST,0,
1444                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1445         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1446         force_next(token);
1447     }
1448     return s;
1449 }
1450
1451 /*
1452  * S_force_ident
1453  * Called when the lexer wants $foo *foo &foo etc, but the program
1454  * text only contains the "foo" portion.  The first argument is a pointer
1455  * to the "foo", and the second argument is the type symbol to prefix.
1456  * Forces the next token to be a "WORD".
1457  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1458  */
1459
1460 STATIC void
1461 S_force_ident(pTHX_ register const char *s, int kind)
1462 {
1463     dVAR;
1464
1465     PERL_ARGS_ASSERT_FORCE_IDENT;
1466
1467     if (*s) {
1468         const STRLEN len = strlen(s);
1469         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1470         start_force(PL_curforce);
1471         NEXTVAL_NEXTTOKE.opval = o;
1472         force_next(WORD);
1473         if (kind) {
1474             o->op_private = OPpCONST_ENTERED;
1475             /* XXX see note in pp_entereval() for why we forgo typo
1476                warnings if the symbol must be introduced in an eval.
1477                GSAR 96-10-12 */
1478             gv_fetchpvn_flags(s, len,
1479                               PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1480                               : GV_ADD,
1481                               kind == '$' ? SVt_PV :
1482                               kind == '@' ? SVt_PVAV :
1483                               kind == '%' ? SVt_PVHV :
1484                               SVt_PVGV
1485                               );
1486         }
1487     }
1488 }
1489
1490 NV
1491 Perl_str_to_version(pTHX_ SV *sv)
1492 {
1493     NV retval = 0.0;
1494     NV nshift = 1.0;
1495     STRLEN len;
1496     const char *start = SvPV_const(sv,len);
1497     const char * const end = start + len;
1498     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1499
1500     PERL_ARGS_ASSERT_STR_TO_VERSION;
1501
1502     while (start < end) {
1503         STRLEN skip;
1504         UV n;
1505         if (utf)
1506             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1507         else {
1508             n = *(U8*)start;
1509             skip = 1;
1510         }
1511         retval += ((NV)n)/nshift;
1512         start += skip;
1513         nshift *= 1000;
1514     }
1515     return retval;
1516 }
1517
1518 /*
1519  * S_force_version
1520  * Forces the next token to be a version number.
1521  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1522  * and if "guessing" is TRUE, then no new token is created (and the caller
1523  * must use an alternative parsing method).
1524  */
1525
1526 STATIC char *
1527 S_force_version(pTHX_ char *s, int guessing)
1528 {
1529     dVAR;
1530     OP *version = NULL;
1531     char *d;
1532 #ifdef PERL_MAD
1533     I32 startoff = s - SvPVX(PL_linestr);
1534 #endif
1535
1536     PERL_ARGS_ASSERT_FORCE_VERSION;
1537
1538     s = SKIPSPACE1(s);
1539
1540     d = s;
1541     if (*d == 'v')
1542         d++;
1543     if (isDIGIT(*d)) {
1544         while (isDIGIT(*d) || *d == '_' || *d == '.')
1545             d++;
1546 #ifdef PERL_MAD
1547         if (PL_madskills) {
1548             start_force(PL_curforce);
1549             curmad('X', newSVpvn(s,d-s));
1550         }
1551 #endif
1552         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1553             SV *ver;
1554             s = scan_num(s, &pl_yylval);
1555             version = pl_yylval.opval;
1556             ver = cSVOPx(version)->op_sv;
1557             if (SvPOK(ver) && !SvNIOK(ver)) {
1558                 SvUPGRADE(ver, SVt_PVNV);
1559                 SvNV_set(ver, str_to_version(ver));
1560                 SvNOK_on(ver);          /* hint that it is a version */
1561             }
1562         }
1563         else if (guessing) {
1564 #ifdef PERL_MAD
1565             if (PL_madskills) {
1566                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
1567                 PL_nextwhite = 0;
1568                 s = SvPVX(PL_linestr) + startoff;
1569             }
1570 #endif
1571             return s;
1572         }
1573     }
1574
1575 #ifdef PERL_MAD
1576     if (PL_madskills && !version) {
1577         sv_free(PL_nextwhite);  /* let next token collect whitespace */
1578         PL_nextwhite = 0;
1579         s = SvPVX(PL_linestr) + startoff;
1580     }
1581 #endif
1582     /* NOTE: The parser sees the package name and the VERSION swapped */
1583     start_force(PL_curforce);
1584     NEXTVAL_NEXTTOKE.opval = version;
1585     force_next(WORD);
1586
1587     return s;
1588 }
1589
1590 /*
1591  * S_tokeq
1592  * Tokenize a quoted string passed in as an SV.  It finds the next
1593  * chunk, up to end of string or a backslash.  It may make a new
1594  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1595  * turns \\ into \.
1596  */
1597
1598 STATIC SV *
1599 S_tokeq(pTHX_ SV *sv)
1600 {
1601     dVAR;
1602     register char *s;
1603     register char *send;
1604     register char *d;
1605     STRLEN len = 0;
1606     SV *pv = sv;
1607
1608     PERL_ARGS_ASSERT_TOKEQ;
1609
1610     if (!SvLEN(sv))
1611         goto finish;
1612
1613     s = SvPV_force(sv, len);
1614     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1615         goto finish;
1616     send = s + len;
1617     while (s < send && *s != '\\')
1618         s++;
1619     if (s == send)
1620         goto finish;
1621     d = s;
1622     if ( PL_hints & HINT_NEW_STRING ) {
1623         pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1624     }
1625     while (s < send) {
1626         if (*s == '\\') {
1627             if (s + 1 < send && (s[1] == '\\'))
1628                 s++;            /* all that, just for this */
1629         }
1630         *d++ = *s++;
1631     }
1632     *d = '\0';
1633     SvCUR_set(sv, d - SvPVX_const(sv));
1634   finish:
1635     if ( PL_hints & HINT_NEW_STRING )
1636        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1637     return sv;
1638 }
1639
1640 /*
1641  * Now come three functions related to double-quote context,
1642  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1643  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1644  * interact with PL_lex_state, and create fake ( ... ) argument lists
1645  * to handle functions and concatenation.
1646  * They assume that whoever calls them will be setting up a fake
1647  * join call, because each subthing puts a ',' after it.  This lets
1648  *   "lower \luPpEr"
1649  * become
1650  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1651  *
1652  * (I'm not sure whether the spurious commas at the end of lcfirst's
1653  * arguments and join's arguments are created or not).
1654  */
1655
1656 /*
1657  * S_sublex_start
1658  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1659  *
1660  * Pattern matching will set PL_lex_op to the pattern-matching op to
1661  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1662  *
1663  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1664  *
1665  * Everything else becomes a FUNC.
1666  *
1667  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1668  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1669  * call to S_sublex_push().
1670  */
1671
1672 STATIC I32
1673 S_sublex_start(pTHX)
1674 {
1675     dVAR;
1676     register const I32 op_type = pl_yylval.ival;
1677
1678     if (op_type == OP_NULL) {
1679         pl_yylval.opval = PL_lex_op;
1680         PL_lex_op = NULL;
1681         return THING;
1682     }
1683     if (op_type == OP_CONST || op_type == OP_READLINE) {
1684         SV *sv = tokeq(PL_lex_stuff);
1685
1686         if (SvTYPE(sv) == SVt_PVIV) {
1687             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1688             STRLEN len;
1689             const char * const p = SvPV_const(sv, len);
1690             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1691             SvREFCNT_dec(sv);
1692             sv = nsv;
1693         }
1694         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1695         PL_lex_stuff = NULL;
1696         /* Allow <FH> // "foo" */
1697         if (op_type == OP_READLINE)
1698             PL_expect = XTERMORDORDOR;
1699         return THING;
1700     }
1701     else if (op_type == OP_BACKTICK && PL_lex_op) {
1702         /* readpipe() vas overriden */
1703         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1704         pl_yylval.opval = PL_lex_op;
1705         PL_lex_op = NULL;
1706         PL_lex_stuff = NULL;
1707         return THING;
1708     }
1709
1710     PL_sublex_info.super_state = PL_lex_state;
1711     PL_sublex_info.sub_inwhat = (U16)op_type;
1712     PL_sublex_info.sub_op = PL_lex_op;
1713     PL_lex_state = LEX_INTERPPUSH;
1714
1715     PL_expect = XTERM;
1716     if (PL_lex_op) {
1717         pl_yylval.opval = PL_lex_op;
1718         PL_lex_op = NULL;
1719         return PMFUNC;
1720     }
1721     else
1722         return FUNC;
1723 }
1724
1725 /*
1726  * S_sublex_push
1727  * Create a new scope to save the lexing state.  The scope will be
1728  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1729  * to the uc, lc, etc. found before.
1730  * Sets PL_lex_state to LEX_INTERPCONCAT.
1731  */
1732
1733 STATIC I32
1734 S_sublex_push(pTHX)
1735 {
1736     dVAR;
1737     ENTER;
1738
1739     PL_lex_state = PL_sublex_info.super_state;
1740     SAVEBOOL(PL_lex_dojoin);
1741     SAVEI32(PL_lex_brackets);
1742     SAVEI32(PL_lex_casemods);
1743     SAVEI32(PL_lex_starts);
1744     SAVEI8(PL_lex_state);
1745     SAVEVPTR(PL_lex_inpat);
1746     SAVEI16(PL_lex_inwhat);
1747     SAVECOPLINE(PL_curcop);
1748     SAVEPPTR(PL_bufptr);
1749     SAVEPPTR(PL_bufend);
1750     SAVEPPTR(PL_oldbufptr);
1751     SAVEPPTR(PL_oldoldbufptr);
1752     SAVEPPTR(PL_last_lop);
1753     SAVEPPTR(PL_last_uni);
1754     SAVEPPTR(PL_linestart);
1755     SAVESPTR(PL_linestr);
1756     SAVEGENERICPV(PL_lex_brackstack);
1757     SAVEGENERICPV(PL_lex_casestack);
1758
1759     PL_linestr = PL_lex_stuff;
1760     PL_lex_stuff = NULL;
1761
1762     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1763         = SvPVX(PL_linestr);
1764     PL_bufend += SvCUR(PL_linestr);
1765     PL_last_lop = PL_last_uni = NULL;
1766     SAVEFREESV(PL_linestr);
1767
1768     PL_lex_dojoin = FALSE;
1769     PL_lex_brackets = 0;
1770     Newx(PL_lex_brackstack, 120, char);
1771     Newx(PL_lex_casestack, 12, char);
1772     PL_lex_casemods = 0;
1773     *PL_lex_casestack = '\0';
1774     PL_lex_starts = 0;
1775     PL_lex_state = LEX_INTERPCONCAT;
1776     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1777
1778     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1779     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1780         PL_lex_inpat = PL_sublex_info.sub_op;
1781     else
1782         PL_lex_inpat = NULL;
1783
1784     return '(';
1785 }
1786
1787 /*
1788  * S_sublex_done
1789  * Restores lexer state after a S_sublex_push.
1790  */
1791
1792 STATIC I32
1793 S_sublex_done(pTHX)
1794 {
1795     dVAR;
1796     if (!PL_lex_starts++) {
1797         SV * const sv = newSVpvs("");
1798         if (SvUTF8(PL_linestr))
1799             SvUTF8_on(sv);
1800         PL_expect = XOPERATOR;
1801         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1802         return THING;
1803     }
1804
1805     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1806         PL_lex_state = LEX_INTERPCASEMOD;
1807         return yylex();
1808     }
1809
1810     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1811     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1812         PL_linestr = PL_lex_repl;
1813         PL_lex_inpat = 0;
1814         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1815         PL_bufend += SvCUR(PL_linestr);
1816         PL_last_lop = PL_last_uni = NULL;
1817         SAVEFREESV(PL_linestr);
1818         PL_lex_dojoin = FALSE;
1819         PL_lex_brackets = 0;
1820         PL_lex_casemods = 0;
1821         *PL_lex_casestack = '\0';
1822         PL_lex_starts = 0;
1823         if (SvEVALED(PL_lex_repl)) {
1824             PL_lex_state = LEX_INTERPNORMAL;
1825             PL_lex_starts++;
1826             /*  we don't clear PL_lex_repl here, so that we can check later
1827                 whether this is an evalled subst; that means we rely on the
1828                 logic to ensure sublex_done() is called again only via the
1829                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1830         }
1831         else {
1832             PL_lex_state = LEX_INTERPCONCAT;
1833             PL_lex_repl = NULL;
1834         }
1835         return ',';
1836     }
1837     else {
1838 #ifdef PERL_MAD
1839         if (PL_madskills) {
1840             if (PL_thiswhite) {
1841                 if (!PL_endwhite)
1842                     PL_endwhite = newSVpvs("");
1843                 sv_catsv(PL_endwhite, PL_thiswhite);
1844                 PL_thiswhite = 0;
1845             }
1846             if (PL_thistoken)
1847                 sv_setpvs(PL_thistoken,"");
1848             else
1849                 PL_realtokenstart = -1;
1850         }
1851 #endif
1852         LEAVE;
1853         PL_bufend = SvPVX(PL_linestr);
1854         PL_bufend += SvCUR(PL_linestr);
1855         PL_expect = XOPERATOR;
1856         PL_sublex_info.sub_inwhat = 0;
1857         return ')';
1858     }
1859 }
1860
1861 /*
1862   scan_const
1863
1864   Extracts a pattern, double-quoted string, or transliteration.  This
1865   is terrifying code.
1866
1867   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1868   processing a pattern (PL_lex_inpat is true), a transliteration
1869   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1870
1871   Returns a pointer to the character scanned up to. If this is
1872   advanced from the start pointer supplied (i.e. if anything was
1873   successfully parsed), will leave an OP for the substring scanned
1874   in pl_yylval. Caller must intuit reason for not parsing further
1875   by looking at the next characters herself.
1876
1877   In patterns:
1878     backslashes:
1879       double-quoted style: \r and \n
1880       regexp special ones: \D \s
1881       constants: \x31
1882       backrefs: \1
1883       case and quoting: \U \Q \E
1884     stops on @ and $, but not for $ as tail anchor
1885
1886   In transliterations:
1887     characters are VERY literal, except for - not at the start or end
1888     of the string, which indicates a range. If the range is in bytes,
1889     scan_const expands the range to the full set of intermediate
1890     characters. If the range is in utf8, the hyphen is replaced with
1891     a certain range mark which will be handled by pmtrans() in op.c.
1892
1893   In double-quoted strings:
1894     backslashes:
1895       double-quoted style: \r and \n
1896       constants: \x31
1897       deprecated backrefs: \1 (in substitution replacements)
1898       case and quoting: \U \Q \E
1899     stops on @ and $
1900
1901   scan_const does *not* construct ops to handle interpolated strings.
1902   It stops processing as soon as it finds an embedded $ or @ variable
1903   and leaves it to the caller to work out what's going on.
1904
1905   embedded arrays (whether in pattern or not) could be:
1906       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1907
1908   $ in double-quoted strings must be the symbol of an embedded scalar.
1909
1910   $ in pattern could be $foo or could be tail anchor.  Assumption:
1911   it's a tail anchor if $ is the last thing in the string, or if it's
1912   followed by one of "()| \r\n\t"
1913
1914   \1 (backreferences) are turned into $1
1915
1916   The structure of the code is
1917       while (there's a character to process) {
1918           handle transliteration ranges
1919           skip regexp comments /(?#comment)/ and codes /(?{code})/
1920           skip #-initiated comments in //x patterns
1921           check for embedded arrays
1922           check for embedded scalars
1923           if (backslash) {
1924               leave intact backslashes from leaveit (below)
1925               deprecate \1 in substitution replacements
1926               handle string-changing backslashes \l \U \Q \E, etc.
1927               switch (what was escaped) {
1928                   handle \- in a transliteration (becomes a literal -)
1929                   handle \132 (octal characters)
1930                   handle \x15 and \x{1234} (hex characters)
1931                   handle \N{name} (named characters)
1932                   handle \cV (control characters)
1933                   handle printf-style backslashes (\f, \r, \n, etc)
1934               } (end switch)
1935               continue
1936           } (end if backslash)
1937           handle regular character
1938     } (end while character to read)
1939
1940 */
1941
1942 STATIC char *
1943 S_scan_const(pTHX_ char *start)
1944 {
1945     dVAR;
1946     register char *send = PL_bufend;            /* end of the constant */
1947     SV *sv = newSV(send - start);               /* sv for the constant.  See
1948                                                    note below on sizing. */
1949     register char *s = start;                   /* start of the constant */
1950     register char *d = SvPVX(sv);               /* destination for copies */
1951     bool dorange = FALSE;                       /* are we in a translit range? */
1952     bool didrange = FALSE;                      /* did we just finish a range? */
1953     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1954     I32  this_utf8 = UTF;                       /* Is the source string assumed
1955                                                    to be UTF8?  But, this can
1956                                                    show as true when the source
1957                                                    isn't utf8, as for example
1958                                                    when it is entirely composed
1959                                                    of hex constants */
1960
1961     /* Note on sizing:  The scanned constant is placed into sv, which is
1962      * initialized by newSV() assuming one byte of output for every byte of
1963      * input.  This routine expects newSV() to allocate an extra byte for a
1964      * trailing NUL, which this routine will append if it gets to the end of
1965      * the input.  There may be more bytes of input than output (eg., \N{LATIN
1966      * CAPITAL LETTER A}), or more output than input if the constant ends up
1967      * recoded to utf8, but each time a construct is found that might increase
1968      * the needed size, SvGROW() is called.  Its size parameter each time is
1969      * based on the best guess estimate at the time, namely the length used so
1970      * far, plus the length the current construct will occupy, plus room for
1971      * the trailing NUL, plus one byte for every input byte still unscanned */
1972
1973     UV uv;
1974 #ifdef EBCDIC
1975     UV literal_endpoint = 0;
1976     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1977 #endif
1978
1979     PERL_ARGS_ASSERT_SCAN_CONST;
1980
1981     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1982         /* If we are doing a trans and we know we want UTF8 set expectation */
1983         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1984         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1985     }
1986
1987
1988     while (s < send || dorange) {
1989         /* get transliterations out of the way (they're most literal) */
1990         if (PL_lex_inwhat == OP_TRANS) {
1991             /* expand a range A-Z to the full set of characters.  AIE! */
1992             if (dorange) {
1993                 I32 i;                          /* current expanded character */
1994                 I32 min;                        /* first character in range */
1995                 I32 max;                        /* last character in range */
1996
1997 #ifdef EBCDIC
1998                 UV uvmax = 0;
1999 #endif
2000
2001                 if (has_utf8
2002 #ifdef EBCDIC
2003                     && !native_range
2004 #endif
2005                     ) {
2006                     char * const c = (char*)utf8_hop((U8*)d, -1);
2007                     char *e = d++;
2008                     while (e-- > c)
2009                         *(e + 1) = *e;
2010                     *c = (char)UTF_TO_NATIVE(0xff);
2011                     /* mark the range as done, and continue */
2012                     dorange = FALSE;
2013                     didrange = TRUE;
2014                     continue;
2015                 }
2016
2017                 i = d - SvPVX_const(sv);                /* remember current offset */
2018 #ifdef EBCDIC
2019                 SvGROW(sv,
2020                        SvLEN(sv) + (has_utf8 ?
2021                                     (512 - UTF_CONTINUATION_MARK +
2022                                      UNISKIP(0x100))
2023                                     : 256));
2024                 /* How many two-byte within 0..255: 128 in UTF-8,
2025                  * 96 in UTF-8-mod. */
2026 #else
2027                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
2028 #endif
2029                 d = SvPVX(sv) + i;              /* refresh d after realloc */
2030 #ifdef EBCDIC
2031                 if (has_utf8) {
2032                     int j;
2033                     for (j = 0; j <= 1; j++) {
2034                         char * const c = (char*)utf8_hop((U8*)d, -1);
2035                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2036                         if (j)
2037                             min = (U8)uv;
2038                         else if (uv < 256)
2039                             max = (U8)uv;
2040                         else {
2041                             max = (U8)0xff; /* only to \xff */
2042                             uvmax = uv; /* \x{100} to uvmax */
2043                         }
2044                         d = c; /* eat endpoint chars */
2045                      }
2046                 }
2047                else {
2048 #endif
2049                    d -= 2;              /* eat the first char and the - */
2050                    min = (U8)*d;        /* first char in range */
2051                    max = (U8)d[1];      /* last char in range  */
2052 #ifdef EBCDIC
2053                }
2054 #endif
2055
2056                 if (min > max) {
2057                     Perl_croak(aTHX_
2058                                "Invalid range \"%c-%c\" in transliteration operator",
2059                                (char)min, (char)max);
2060                 }
2061
2062 #ifdef EBCDIC
2063                 if (literal_endpoint == 2 &&
2064                     ((isLOWER(min) && isLOWER(max)) ||
2065                      (isUPPER(min) && isUPPER(max)))) {
2066                     if (isLOWER(min)) {
2067                         for (i = min; i <= max; i++)
2068                             if (isLOWER(i))
2069                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
2070                     } else {
2071                         for (i = min; i <= max; i++)
2072                             if (isUPPER(i))
2073                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
2074                     }
2075                 }
2076                 else
2077 #endif
2078                     for (i = min; i <= max; i++)
2079 #ifdef EBCDIC
2080                         if (has_utf8) {
2081                             const U8 ch = (U8)NATIVE_TO_UTF(i);
2082                             if (UNI_IS_INVARIANT(ch))
2083                                 *d++ = (U8)i;
2084                             else {
2085                                 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2086                                 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2087                             }
2088                         }
2089                         else
2090 #endif
2091                             *d++ = (char)i;
2092
2093 #ifdef EBCDIC
2094                 if (uvmax) {
2095                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2096                     if (uvmax > 0x101)
2097                         *d++ = (char)UTF_TO_NATIVE(0xff);
2098                     if (uvmax > 0x100)
2099                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2100                 }
2101 #endif
2102
2103                 /* mark the range as done, and continue */
2104                 dorange = FALSE;
2105                 didrange = TRUE;
2106 #ifdef EBCDIC
2107                 literal_endpoint = 0;
2108 #endif
2109                 continue;
2110             }
2111
2112             /* range begins (ignore - as first or last char) */
2113             else if (*s == '-' && s+1 < send  && s != start) {
2114                 if (didrange) {
2115                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2116                 }
2117                 if (has_utf8
2118 #ifdef EBCDIC
2119                     && !native_range
2120 #endif
2121                     ) {
2122                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
2123                     s++;
2124                     continue;
2125                 }
2126                 dorange = TRUE;
2127                 s++;
2128             }
2129             else {
2130                 didrange = FALSE;
2131 #ifdef EBCDIC
2132                 literal_endpoint = 0;
2133                 native_range = TRUE;
2134 #endif
2135             }
2136         }
2137
2138         /* if we get here, we're not doing a transliteration */
2139
2140         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2141            except for the last char, which will be done separately. */
2142         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2143             if (s[2] == '#') {
2144                 while (s+1 < send && *s != ')')
2145                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2146             }
2147             else if (s[2] == '{' /* This should match regcomp.c */
2148                     || (s[2] == '?' && s[3] == '{'))
2149             {
2150                 I32 count = 1;
2151                 char *regparse = s + (s[2] == '{' ? 3 : 4);
2152                 char c;
2153
2154                 while (count && (c = *regparse)) {
2155                     if (c == '\\' && regparse[1])
2156                         regparse++;
2157                     else if (c == '{')
2158                         count++;
2159                     else if (c == '}')
2160                         count--;
2161                     regparse++;
2162                 }
2163                 if (*regparse != ')')
2164                     regparse--;         /* Leave one char for continuation. */
2165                 while (s < regparse)
2166                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2167             }
2168         }
2169
2170         /* likewise skip #-initiated comments in //x patterns */
2171         else if (*s == '#' && PL_lex_inpat &&
2172           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2173             while (s+1 < send && *s != '\n')
2174                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2175         }
2176
2177         /* check for embedded arrays
2178            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2179            */
2180         else if (*s == '@' && s[1]) {
2181             if (isALNUM_lazy_if(s+1,UTF))
2182                 break;
2183             if (strchr(":'{$", s[1]))
2184                 break;
2185             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2186                 break; /* in regexp, neither @+ nor @- are interpolated */
2187         }
2188
2189         /* check for embedded scalars.  only stop if we're sure it's a
2190            variable.
2191         */
2192         else if (*s == '$') {
2193             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
2194                 break;
2195             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2196                 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2197                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2198                                 "Possible unintended interpolation of $\\ in regex");
2199                 }
2200                 break;          /* in regexp, $ might be tail anchor */
2201             }
2202         }
2203
2204         /* End of else if chain - OP_TRANS rejoin rest */
2205
2206         /* backslashes */
2207         if (*s == '\\' && s+1 < send) {
2208             s++;
2209
2210             /* deprecate \1 in strings and substitution replacements */
2211             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2212                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2213             {
2214                 if (ckWARN(WARN_SYNTAX))
2215                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2216                 *--s = '$';
2217                 break;
2218             }
2219
2220             /* string-change backslash escapes */
2221             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2222                 --s;
2223                 break;
2224             }
2225             /* skip any other backslash escapes in a pattern */
2226             else if (PL_lex_inpat) {
2227                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2228                 goto default_action;
2229             }
2230
2231             /* if we get here, it's either a quoted -, or a digit */
2232             switch (*s) {
2233
2234             /* quoted - in transliterations */
2235             case '-':
2236                 if (PL_lex_inwhat == OP_TRANS) {
2237                     *d++ = *s++;
2238                     continue;
2239                 }
2240                 /* FALL THROUGH */
2241             default:
2242                 {
2243                     if ((isALPHA(*s) || isDIGIT(*s)) &&
2244                         ckWARN(WARN_MISC))
2245                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2246                                     "Unrecognized escape \\%c passed through",
2247                                     *s);
2248                     /* default action is to copy the quoted character */
2249                     goto default_action;
2250                 }
2251
2252             /* eg. \132 indicates the octal constant 0x132 */
2253             case '0': case '1': case '2': case '3':
2254             case '4': case '5': case '6': case '7':
2255                 {
2256                     I32 flags = 0;
2257                     STRLEN len = 3;
2258                     uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2259                     s += len;
2260                 }
2261                 goto NUM_ESCAPE_INSERT;
2262
2263             /* eg. \x24 indicates the hex constant 0x24 */
2264             case 'x':
2265                 ++s;
2266                 if (*s == '{') {
2267                     char* const e = strchr(s, '}');
2268                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2269                       PERL_SCAN_DISALLOW_PREFIX;
2270                     STRLEN len;
2271
2272                     ++s;
2273                     if (!e) {
2274                         yyerror("Missing right brace on \\x{}");
2275                         continue;
2276                     }
2277                     len = e - s;
2278                     uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2279                     s = e + 1;
2280                 }
2281                 else {
2282                     {
2283                         STRLEN len = 2;
2284                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2285                         uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2286                         s += len;
2287                     }
2288                 }
2289
2290               NUM_ESCAPE_INSERT:
2291                 /* Insert oct, hex, or \N{U+...} escaped character.  There will
2292                  * always be enough room in sv since such escapes will be
2293                  * longer than any UTF-8 sequence they can end up as, except if
2294                  * they force us to recode the rest of the string into utf8 */
2295
2296                 /* Here uv is the ordinal of the next character being added in
2297                  * unicode (converted from native).  (It has to be done before
2298                  * here because \N is interpreted as unicode, and oct and hex
2299                  * as native.) */
2300                 if (!UNI_IS_INVARIANT(uv)) {
2301                     if (!has_utf8 && uv > 255) {
2302                         /* Might need to recode whatever we have accumulated so
2303                          * far if it contains any chars variant in utf8 or
2304                          * utf-ebcdic. */
2305
2306                         SvCUR_set(sv, d - SvPVX_const(sv));
2307                         SvPOK_on(sv);
2308                         *d = '\0';
2309                         /* See Note on sizing above.  */
2310                         sv_utf8_upgrade_flags_grow(sv,
2311                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2312                                         UNISKIP(uv) + (STRLEN)(send - s) + 1);
2313                         d = SvPVX(sv) + SvCUR(sv);
2314                         has_utf8 = TRUE;
2315                     }
2316
2317                     if (has_utf8) {
2318                         d = (char*)uvuni_to_utf8((U8*)d, uv);
2319                         if (PL_lex_inwhat == OP_TRANS &&
2320                             PL_sublex_info.sub_op) {
2321                             PL_sublex_info.sub_op->op_private |=
2322                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2323                                              : OPpTRANS_TO_UTF);
2324                         }
2325 #ifdef EBCDIC
2326                         if (uv > 255 && !dorange)
2327                             native_range = FALSE;
2328 #endif
2329                     }
2330                     else {
2331                         *d++ = (char)uv;
2332                     }
2333                 }
2334                 else {
2335                     *d++ = (char) uv;
2336                 }
2337                 continue;
2338
2339             /* \N{LATIN SMALL LETTER A} is a named character, and so is
2340              * \N{U+0041} */
2341             case 'N':
2342                 ++s;
2343                 if (*s == '{') {
2344                     char* e = strchr(s, '}');
2345                     SV *res;
2346                     STRLEN len;
2347                     const char *str;
2348
2349                     if (!e) {
2350                         yyerror("Missing right brace on \\N{}");
2351                         e = s - 1;
2352                         goto cont_scan;
2353                     }
2354                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2355                         /* \N{U+...} The ... is a unicode value even on EBCDIC
2356                          * machines */
2357                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2358                           PERL_SCAN_DISALLOW_PREFIX;
2359                         s += 3;
2360                         len = e - s;
2361                         uv = grok_hex(s, &len, &flags, NULL);
2362                         if ( e > s && len != (STRLEN)(e - s) ) {
2363                             uv = 0xFFFD;
2364                         }
2365                         s = e + 1;
2366                         goto NUM_ESCAPE_INSERT;
2367                     }
2368                     res = newSVpvn(s + 1, e - s - 1);
2369                     res = new_constant( NULL, 0, "charnames",
2370                                         res, NULL, s - 2, e - s + 3 );
2371                     if (has_utf8)
2372                         sv_utf8_upgrade(res);
2373                     str = SvPV_const(res,len);
2374 #ifdef EBCDIC_NEVER_MIND
2375                     /* charnames uses pack U and that has been
2376                      * recently changed to do the below uni->native
2377                      * mapping, so this would be redundant (and wrong,
2378                      * the code point would be doubly converted).
2379                      * But leave this in just in case the pack U change
2380                      * gets revoked, but the semantics is still
2381                      * desireable for charnames. --jhi */
2382                     {
2383                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2384
2385                          if (uv < 0x100) {
2386                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2387
2388                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2389                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2390                               str = SvPV_const(res, len);
2391                          }
2392                     }
2393 #endif
2394                     /* If destination is not in utf8 but this new character is,
2395                      * recode the dest to utf8 */
2396                     if (!has_utf8 && SvUTF8(res)) {
2397                         SvCUR_set(sv, d - SvPVX_const(sv));
2398                         SvPOK_on(sv);
2399                         *d = '\0';
2400                         /* See Note on sizing above.  */
2401                         sv_utf8_upgrade_flags_grow(sv,
2402                                             SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2403                                             len + (STRLEN)(send - s) + 1);
2404                         d = SvPVX(sv) + SvCUR(sv);
2405                         has_utf8 = TRUE;
2406                     } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2407
2408                         /* See Note on sizing above.  (NOTE: SvCUR() is not set
2409                          * correctly here). */
2410                         const STRLEN off = d - SvPVX_const(sv);
2411                         d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2412                     }
2413 #ifdef EBCDIC
2414                     if (!dorange)
2415                         native_range = FALSE; /* \N{} is guessed to be Unicode */
2416 #endif
2417                     Copy(str, d, len, char);
2418                     d += len;
2419                     SvREFCNT_dec(res);
2420                   cont_scan:
2421                     s = e + 1;
2422                 }
2423                 else
2424                     yyerror("Missing braces on \\N{}");
2425                 continue;
2426
2427             /* \c is a control character */
2428             case 'c':
2429                 s++;
2430                 if (s < send) {
2431                     U8 c = *s++;
2432 #ifdef EBCDIC
2433                     if (isLOWER(c))
2434                         c = toUPPER(c);
2435 #endif
2436                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2437                 }
2438                 else {
2439                     yyerror("Missing control char name in \\c");
2440                 }
2441                 continue;
2442
2443             /* printf-style backslashes, formfeeds, newlines, etc */
2444             case 'b':
2445                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2446                 break;
2447             case 'n':
2448                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2449                 break;
2450             case 'r':
2451                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2452                 break;
2453             case 'f':
2454                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2455                 break;
2456             case 't':
2457                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2458                 break;
2459             case 'e':
2460                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2461                 break;
2462             case 'a':
2463                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2464                 break;
2465             } /* end switch */
2466
2467             s++;
2468             continue;
2469         } /* end if (backslash) */
2470 #ifdef EBCDIC
2471         else
2472             literal_endpoint++;
2473 #endif
2474
2475     default_action:
2476         /* If we started with encoded form, or already know we want it,
2477            then encode the next character */
2478         if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2479             STRLEN len  = 1;
2480
2481
2482             /* One might think that it is wasted effort in the case of the
2483              * source being utf8 (this_utf8 == TRUE) to take the next character
2484              * in the source, convert it to an unsigned value, and then convert
2485              * it back again.  But the source has not been validated here.  The
2486              * routine that does the conversion checks for errors like
2487              * malformed utf8 */
2488
2489             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2490             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2491             if (!has_utf8) {
2492                 SvCUR_set(sv, d - SvPVX_const(sv));
2493                 SvPOK_on(sv);
2494                 *d = '\0';
2495                 /* See Note on sizing above.  */
2496                 sv_utf8_upgrade_flags_grow(sv,
2497                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2498                                         need + (STRLEN)(send - s) + 1);
2499                 d = SvPVX(sv) + SvCUR(sv);
2500                 has_utf8 = TRUE;
2501             } else if (need > len) {
2502                 /* encoded value larger than old, may need extra space (NOTE:
2503                  * SvCUR() is not set correctly here).   See Note on sizing
2504                  * above.  */
2505                 const STRLEN off = d - SvPVX_const(sv);
2506                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2507             }
2508             s += len;
2509
2510             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2511 #ifdef EBCDIC
2512             if (uv > 255 && !dorange)
2513                 native_range = FALSE;
2514 #endif
2515         }
2516         else {
2517             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2518         }
2519     } /* while loop to process each character */
2520
2521     /* terminate the string and set up the sv */
2522     *d = '\0';
2523     SvCUR_set(sv, d - SvPVX_const(sv));
2524     if (SvCUR(sv) >= SvLEN(sv))
2525         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2526
2527     SvPOK_on(sv);
2528     if (PL_encoding && !has_utf8) {
2529         sv_recode_to_utf8(sv, PL_encoding);
2530         if (SvUTF8(sv))
2531             has_utf8 = TRUE;
2532     }
2533     if (has_utf8) {
2534         SvUTF8_on(sv);
2535         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2536             PL_sublex_info.sub_op->op_private |=
2537                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2538         }
2539     }
2540
2541     /* shrink the sv if we allocated more than we used */
2542     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2543         SvPV_shrink_to_cur(sv);
2544     }
2545
2546     /* return the substring (via pl_yylval) only if we parsed anything */
2547     if (s > PL_bufptr) {
2548         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2549             const char *const key = PL_lex_inpat ? "qr" : "q";
2550             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2551             const char *type;
2552             STRLEN typelen;
2553
2554             if (PL_lex_inwhat == OP_TRANS) {
2555                 type = "tr";
2556                 typelen = 2;
2557             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2558                 type = "s";
2559                 typelen = 1;
2560             } else  {
2561                 type = "qq";
2562                 typelen = 2;
2563             }
2564
2565             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2566                                 type, typelen);
2567         }
2568         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2569     } else
2570         SvREFCNT_dec(sv);
2571     return s;
2572 }
2573
2574 /* S_intuit_more
2575  * Returns TRUE if there's more to the expression (e.g., a subscript),
2576  * FALSE otherwise.
2577  *
2578  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2579  *
2580  * ->[ and ->{ return TRUE
2581  * { and [ outside a pattern are always subscripts, so return TRUE
2582  * if we're outside a pattern and it's not { or [, then return FALSE
2583  * if we're in a pattern and the first char is a {
2584  *   {4,5} (any digits around the comma) returns FALSE
2585  * if we're in a pattern and the first char is a [
2586  *   [] returns FALSE
2587  *   [SOMETHING] has a funky algorithm to decide whether it's a
2588  *      character class or not.  It has to deal with things like
2589  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2590  * anything else returns TRUE
2591  */
2592
2593 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2594
2595 STATIC int
2596 S_intuit_more(pTHX_ register char *s)
2597 {
2598     dVAR;
2599
2600     PERL_ARGS_ASSERT_INTUIT_MORE;
2601
2602     if (PL_lex_brackets)
2603         return TRUE;
2604     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2605         return TRUE;
2606     if (*s != '{' && *s != '[')
2607         return FALSE;
2608     if (!PL_lex_inpat)
2609         return TRUE;
2610
2611     /* In a pattern, so maybe we have {n,m}. */
2612     if (*s == '{') {
2613         s++;
2614         if (!isDIGIT(*s))
2615             return TRUE;
2616         while (isDIGIT(*s))
2617             s++;
2618         if (*s == ',')
2619             s++;
2620         while (isDIGIT(*s))
2621             s++;
2622         if (*s == '}')
2623             return FALSE;
2624         return TRUE;
2625
2626     }
2627
2628     /* On the other hand, maybe we have a character class */
2629
2630     s++;
2631     if (*s == ']' || *s == '^')
2632         return FALSE;
2633     else {
2634         /* this is terrifying, and it works */
2635         int weight = 2;         /* let's weigh the evidence */
2636         char seen[256];
2637         unsigned char un_char = 255, last_un_char;
2638         const char * const send = strchr(s,']');
2639         char tmpbuf[sizeof PL_tokenbuf * 4];
2640
2641         if (!send)              /* has to be an expression */
2642             return TRUE;
2643
2644         Zero(seen,256,char);
2645         if (*s == '$')
2646             weight -= 3;
2647         else if (isDIGIT(*s)) {
2648             if (s[1] != ']') {
2649                 if (isDIGIT(s[1]) && s[2] == ']')
2650                     weight -= 10;
2651             }
2652             else
2653                 weight -= 100;
2654         }
2655         for (; s < send; s++) {
2656             last_un_char = un_char;
2657             un_char = (unsigned char)*s;
2658             switch (*s) {
2659             case '@':
2660             case '&':
2661             case '$':
2662                 weight -= seen[un_char] * 10;
2663                 if (isALNUM_lazy_if(s+1,UTF)) {
2664                     int len;
2665                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2666                     len = (int)strlen(tmpbuf);
2667                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2668                         weight -= 100;
2669                     else
2670                         weight -= 10;
2671                 }
2672                 else if (*s == '$' && s[1] &&
2673                   strchr("[#!%*<>()-=",s[1])) {
2674                     if (/*{*/ strchr("])} =",s[2]))
2675                         weight -= 10;
2676                     else
2677                         weight -= 1;
2678                 }
2679                 break;
2680             case '\\':
2681                 un_char = 254;
2682                 if (s[1]) {
2683                     if (strchr("wds]",s[1]))
2684                         weight += 100;
2685                     else if (seen[(U8)'\''] || seen[(U8)'"'])
2686                         weight += 1;
2687                     else if (strchr("rnftbxcav",s[1]))
2688                         weight += 40;
2689                     else if (isDIGIT(s[1])) {
2690                         weight += 40;
2691                         while (s[1] && isDIGIT(s[1]))
2692                             s++;
2693                     }
2694                 }
2695                 else
2696                     weight += 100;
2697                 break;
2698             case '-':
2699                 if (s[1] == '\\')
2700                     weight += 50;
2701                 if (strchr("aA01! ",last_un_char))
2702                     weight += 30;
2703                 if (strchr("zZ79~",s[1]))
2704                     weight += 30;
2705                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2706                     weight -= 5;        /* cope with negative subscript */
2707                 break;
2708             default:
2709                 if (!isALNUM(last_un_char)
2710                     && !(last_un_char == '$' || last_un_char == '@'
2711                          || last_un_char == '&')
2712                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2713                     char *d = tmpbuf;
2714                     while (isALPHA(*s))
2715                         *d++ = *s++;
2716                     *d = '\0';
2717                     if (keyword(tmpbuf, d - tmpbuf, 0))
2718                         weight -= 150;
2719                 }
2720                 if (un_char == last_un_char + 1)
2721                     weight += 5;
2722                 weight -= seen[un_char];
2723                 break;
2724             }
2725             seen[un_char]++;
2726         }
2727         if (weight >= 0)        /* probably a character class */
2728             return FALSE;
2729     }
2730
2731     return TRUE;
2732 }
2733
2734 /*
2735  * S_intuit_method
2736  *
2737  * Does all the checking to disambiguate
2738  *   foo bar
2739  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2740  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2741  *
2742  * First argument is the stuff after the first token, e.g. "bar".
2743  *
2744  * Not a method if bar is a filehandle.
2745  * Not a method if foo is a subroutine prototyped to take a filehandle.
2746  * Not a method if it's really "Foo $bar"
2747  * Method if it's "foo $bar"
2748  * Not a method if it's really "print foo $bar"
2749  * Method if it's really "foo package::" (interpreted as package->foo)
2750  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2751  * Not a method if bar is a filehandle or package, but is quoted with
2752  *   =>
2753  */
2754
2755 STATIC int
2756 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2757 {
2758     dVAR;
2759     char *s = start + (*start == '$');
2760     char tmpbuf[sizeof PL_tokenbuf];
2761     STRLEN len;
2762     GV* indirgv;
2763 #ifdef PERL_MAD
2764     int soff;
2765 #endif
2766
2767     PERL_ARGS_ASSERT_INTUIT_METHOD;
2768
2769     if (gv) {
2770         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2771             return 0;
2772         if (cv) {
2773             if (SvPOK(cv)) {
2774                 const char *proto = SvPVX_const(cv);
2775                 if (proto) {
2776                     if (*proto == ';')
2777                         proto++;
2778                     if (*proto == '*')
2779                         return 0;
2780                 }
2781             }
2782         } else
2783             gv = NULL;
2784     }
2785     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2786     /* start is the beginning of the possible filehandle/object,
2787      * and s is the end of it
2788      * tmpbuf is a copy of it
2789      */
2790
2791     if (*start == '$') {
2792         if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2793                 isUPPER(*PL_tokenbuf))
2794             return 0;
2795 #ifdef PERL_MAD
2796         len = start - SvPVX(PL_linestr);
2797 #endif
2798         s = PEEKSPACE(s);
2799 #ifdef PERL_MAD
2800         start = SvPVX(PL_linestr) + len;
2801 #endif
2802         PL_bufptr = start;
2803         PL_expect = XREF;
2804         return *s == '(' ? FUNCMETH : METHOD;
2805     }
2806     if (!keyword(tmpbuf, len, 0)) {
2807         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2808             len -= 2;
2809             tmpbuf[len] = '\0';
2810 #ifdef PERL_MAD
2811             soff = s - SvPVX(PL_linestr);
2812 #endif
2813             goto bare_package;
2814         }
2815         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2816         if (indirgv && GvCVu(indirgv))
2817             return 0;
2818         /* filehandle or package name makes it a method */
2819         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2820 #ifdef PERL_MAD
2821             soff = s - SvPVX(PL_linestr);
2822 #endif
2823             s = PEEKSPACE(s);
2824             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2825                 return 0;       /* no assumptions -- "=>" quotes bearword */
2826       bare_package:
2827             start_force(PL_curforce);
2828             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2829                                                    newSVpvn(tmpbuf,len));
2830             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2831             if (PL_madskills)
2832                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2833             PL_expect = XTERM;
2834             force_next(WORD);
2835             PL_bufptr = s;
2836 #ifdef PERL_MAD
2837             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2838 #endif
2839             return *s == '(' ? FUNCMETH : METHOD;
2840         }
2841     }
2842     return 0;
2843 }
2844
2845 /* Encoded script support. filter_add() effectively inserts a
2846  * 'pre-processing' function into the current source input stream.
2847  * Note that the filter function only applies to the current source file
2848  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2849  *
2850  * The datasv parameter (which may be NULL) can be used to pass
2851  * private data to this instance of the filter. The filter function
2852  * can recover the SV using the FILTER_DATA macro and use it to
2853  * store private buffers and state information.
2854  *
2855  * The supplied datasv parameter is upgraded to a PVIO type
2856  * and the IoDIRP/IoANY field is used to store the function pointer,
2857  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2858  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2859  * private use must be set using malloc'd pointers.
2860  */
2861
2862 SV *
2863 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2864 {
2865     dVAR;
2866     if (!funcp)
2867         return NULL;
2868
2869     if (!PL_parser)
2870         return NULL;
2871
2872     if (!PL_rsfp_filters)
2873         PL_rsfp_filters = newAV();
2874     if (!datasv)
2875         datasv = newSV(0);
2876     SvUPGRADE(datasv, SVt_PVIO);
2877     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2878     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2879     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2880                           FPTR2DPTR(void *, IoANY(datasv)),
2881                           SvPV_nolen(datasv)));
2882     av_unshift(PL_rsfp_filters, 1);
2883     av_store(PL_rsfp_filters, 0, datasv) ;
2884     return(datasv);
2885 }
2886
2887
2888 /* Delete most recently added instance of this filter function. */
2889 void
2890 Perl_filter_del(pTHX_ filter_t funcp)
2891 {
2892     dVAR;
2893     SV *datasv;
2894
2895     PERL_ARGS_ASSERT_FILTER_DEL;
2896
2897 #ifdef DEBUGGING
2898     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2899                           FPTR2DPTR(void*, funcp)));
2900 #endif
2901     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2902         return;
2903     /* if filter is on top of stack (usual case) just pop it off */
2904     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2905     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2906         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2907         IoANY(datasv) = (void *)NULL;
2908         sv_free(av_pop(PL_rsfp_filters));
2909
2910         return;
2911     }
2912     /* we need to search for the correct entry and clear it     */
2913     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2914 }
2915
2916
2917 /* Invoke the idxth filter function for the current rsfp.        */
2918 /* maxlen 0 = read one text line */
2919 I32
2920 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2921 {
2922     dVAR;
2923     filter_t funcp;
2924     SV *datasv = NULL;
2925     /* This API is bad. It should have been using unsigned int for maxlen.
2926        Not sure if we want to change the API, but if not we should sanity
2927        check the value here.  */
2928     const unsigned int correct_length
2929         = maxlen < 0 ?
2930 #ifdef PERL_MICRO
2931         0x7FFFFFFF
2932 #else
2933         INT_MAX
2934 #endif
2935         : maxlen;
2936
2937     PERL_ARGS_ASSERT_FILTER_READ;
2938
2939     if (!PL_parser || !PL_rsfp_filters)
2940         return -1;
2941     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2942         /* Provide a default input filter to make life easy.    */
2943         /* Note that we append to the line. This is handy.      */
2944         DEBUG_P(PerlIO_printf(Perl_debug_log,
2945                               "filter_read %d: from rsfp\n", idx));
2946         if (correct_length) {
2947             /* Want a block */
2948             int len ;
2949             const int old_len = SvCUR(buf_sv);
2950
2951             /* ensure buf_sv is large enough */
2952             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2953             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2954                                    correct_length)) <= 0) {
2955                 if (PerlIO_error(PL_rsfp))
2956                     return -1;          /* error */
2957                 else
2958                     return 0 ;          /* end of file */
2959             }
2960             SvCUR_set(buf_sv, old_len + len) ;
2961         } else {
2962             /* Want a line */
2963             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2964                 if (PerlIO_error(PL_rsfp))
2965                     return -1;          /* error */
2966                 else
2967                     return 0 ;          /* end of file */
2968             }
2969         }
2970         return SvCUR(buf_sv);
2971     }
2972     /* Skip this filter slot if filter has been deleted */
2973     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2974         DEBUG_P(PerlIO_printf(Perl_debug_log,
2975                               "filter_read %d: skipped (filter deleted)\n",
2976                               idx));
2977         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2978     }
2979     /* Get function pointer hidden within datasv        */
2980     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2981     DEBUG_P(PerlIO_printf(Perl_debug_log,
2982                           "filter_read %d: via function %p (%s)\n",
2983                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
2984     /* Call function. The function is expected to       */
2985     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2986     /* Return: <0:error, =0:eof, >0:not eof             */
2987     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2988 }
2989
2990 STATIC char *
2991 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2992 {
2993     dVAR;
2994
2995     PERL_ARGS_ASSERT_FILTER_GETS;
2996
2997 #ifdef PERL_CR_FILTER
2998     if (!PL_rsfp_filters) {
2999         filter_add(S_cr_textfilter,NULL);
3000     }
3001 #endif
3002     if (PL_rsfp_filters) {
3003         if (!append)
3004             SvCUR_set(sv, 0);   /* start with empty line        */
3005         if (FILTER_READ(0, sv, 0) > 0)
3006             return ( SvPVX(sv) ) ;
3007         else
3008             return NULL ;
3009     }
3010     else
3011         return (sv_gets(sv, fp, append));
3012 }
3013
3014 STATIC HV *
3015 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3016 {
3017     dVAR;
3018     GV *gv;
3019
3020     PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3021
3022     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3023         return PL_curstash;
3024
3025     if (len > 2 &&
3026         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3027         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3028     {
3029         return GvHV(gv);                        /* Foo:: */
3030     }
3031
3032     /* use constant CLASS => 'MyClass' */
3033     gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3034     if (gv && GvCV(gv)) {
3035         SV * const sv = cv_const_sv(GvCV(gv));
3036         if (sv)
3037             pkgname = SvPV_const(sv, len);
3038     }
3039
3040     return gv_stashpvn(pkgname, len, 0);
3041 }
3042
3043 /*
3044  * S_readpipe_override
3045  * Check whether readpipe() is overriden, and generates the appropriate
3046  * optree, provided sublex_start() is called afterwards.
3047  */
3048 STATIC void
3049 S_readpipe_override(pTHX)
3050 {
3051     GV **gvp;
3052     GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3053     pl_yylval.ival = OP_BACKTICK;
3054     if ((gv_readpipe
3055                 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3056             ||
3057             ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3058              && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3059              && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3060     {
3061         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3062             append_elem(OP_LIST,
3063                 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3064                 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3065     }
3066 }
3067
3068 #ifdef PERL_MAD
3069  /*
3070  * Perl_madlex
3071  * The intent of this yylex wrapper is to minimize the changes to the
3072  * tokener when we aren't interested in collecting madprops.  It remains
3073  * to be seen how successful this strategy will be...
3074  */
3075
3076 int
3077 Perl_madlex(pTHX)
3078 {
3079     int optype;
3080     char *s = PL_bufptr;
3081
3082     /* make sure PL_thiswhite is initialized */
3083     PL_thiswhite = 0;
3084     PL_thismad = 0;
3085
3086     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3087     if (PL_pending_ident)
3088         return S_pending_ident(aTHX);
3089
3090     /* previous token ate up our whitespace? */
3091     if (!PL_lasttoke && PL_nextwhite) {
3092         PL_thiswhite = PL_nextwhite;
3093         PL_nextwhite = 0;
3094     }
3095
3096     /* isolate the token, and figure out where it is without whitespace */
3097     PL_realtokenstart = -1;
3098     PL_thistoken = 0;
3099     optype = yylex();
3100     s = PL_bufptr;
3101     assert(PL_curforce < 0);
3102
3103     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
3104         if (!PL_thistoken) {
3105             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3106                 PL_thistoken = newSVpvs("");
3107             else {
3108                 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3109                 PL_thistoken = newSVpvn(tstart, s - tstart);
3110             }
3111         }
3112         if (PL_thismad) /* install head */
3113             CURMAD('X', PL_thistoken);
3114     }
3115
3116     /* last whitespace of a sublex? */
3117     if (optype == ')' && PL_endwhite) {
3118         CURMAD('X', PL_endwhite);
3119     }
3120
3121     if (!PL_thismad) {
3122
3123         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
3124         if (!PL_thiswhite && !PL_endwhite && !optype) {
3125             sv_free(PL_thistoken);
3126             PL_thistoken = 0;
3127             return 0;
3128         }
3129
3130         /* put off final whitespace till peg */
3131         if (optype == ';' && !PL_rsfp) {
3132             PL_nextwhite = PL_thiswhite;
3133             PL_thiswhite = 0;
3134         }
3135         else if (PL_thisopen) {
3136             CURMAD('q', PL_thisopen);
3137             if (PL_thistoken)
3138                 sv_free(PL_thistoken);
3139             PL_thistoken = 0;
3140         }
3141         else {
3142             /* Store actual token text as madprop X */
3143             CURMAD('X', PL_thistoken);
3144         }
3145
3146         if (PL_thiswhite) {
3147             /* add preceding whitespace as madprop _ */
3148             CURMAD('_', PL_thiswhite);
3149         }
3150
3151         if (PL_thisstuff) {
3152             /* add quoted material as madprop = */
3153             CURMAD('=', PL_thisstuff);
3154         }
3155
3156         if (PL_thisclose) {
3157             /* add terminating quote as madprop Q */
3158             CURMAD('Q', PL_thisclose);
3159         }
3160     }
3161
3162     /* special processing based on optype */
3163
3164     switch (optype) {
3165
3166     /* opval doesn't need a TOKEN since it can already store mp */
3167     case WORD:
3168     case METHOD:
3169     case FUNCMETH:
3170     case THING:
3171     case PMFUNC:
3172     case PRIVATEREF:
3173     case FUNC0SUB:
3174     case UNIOPSUB:
3175     case LSTOPSUB:
3176         if (pl_yylval.opval)
3177             append_madprops(PL_thismad, pl_yylval.opval, 0);
3178         PL_thismad = 0;
3179         return optype;
3180
3181     /* fake EOF */
3182     case 0:
3183         optype = PEG;
3184         if (PL_endwhite) {
3185             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3186             PL_endwhite = 0;
3187         }
3188         break;
3189
3190     case ']':
3191     case '}':
3192         if (PL_faketokens)
3193             break;
3194         /* remember any fake bracket that lexer is about to discard */
3195         if (PL_lex_brackets == 1 &&
3196             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3197         {
3198             s = PL_bufptr;
3199             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3200                 s++;
3201             if (*s == '}') {
3202                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3203                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3204                 PL_thiswhite = 0;
3205                 PL_bufptr = s - 1;
3206                 break;  /* don't bother looking for trailing comment */
3207             }
3208             else
3209                 s = PL_bufptr;
3210         }
3211         if (optype == ']')
3212             break;
3213         /* FALLTHROUGH */
3214
3215     /* attach a trailing comment to its statement instead of next token */
3216     case ';':
3217         if (PL_faketokens)
3218             break;
3219         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3220             s = PL_bufptr;
3221             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3222                 s++;
3223             if (*s == '\n' || *s == '#') {
3224                 while (s < PL_bufend && *s != '\n')
3225                     s++;
3226                 if (s < PL_bufend)
3227                     s++;
3228                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3229                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3230                 PL_thiswhite = 0;
3231                 PL_bufptr = s;
3232             }
3233         }
3234         break;
3235
3236     /* pval */
3237     case LABEL:
3238         break;
3239
3240     /* ival */
3241     default:
3242         break;
3243
3244     }
3245
3246     /* Create new token struct.  Note: opvals return early above. */
3247     pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3248     PL_thismad = 0;
3249     return optype;
3250 }
3251 #endif
3252
3253 STATIC char *
3254 S_tokenize_use(pTHX_ int is_use, char *s) {
3255     dVAR;
3256
3257     PERL_ARGS_ASSERT_TOKENIZE_USE;
3258
3259     if (PL_expect != XSTATE)
3260         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3261                     is_use ? "use" : "no"));
3262     s = SKIPSPACE1(s);
3263     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3264         s = force_version(s, TRUE);
3265         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3266             start_force(PL_curforce);
3267             NEXTVAL_NEXTTOKE.opval = NULL;
3268             force_next(WORD);
3269         }
3270         else if (*s == 'v') {
3271             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3272             s = force_version(s, FALSE);
3273         }
3274     }
3275     else {
3276         s = force_word(s,WORD,FALSE,TRUE,FALSE);
3277         s = force_version(s, FALSE);
3278     }
3279     pl_yylval.ival = is_use;
3280     return s;
3281 }
3282 #ifdef DEBUGGING
3283     static const char* const exp_name[] =
3284         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3285           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3286         };
3287 #endif
3288
3289 /*
3290   yylex
3291
3292   Works out what to call the token just pulled out of the input
3293   stream.  The yacc parser takes care of taking the ops we return and
3294   stitching them into a tree.
3295
3296   Returns:
3297     PRIVATEREF
3298
3299   Structure:
3300       if read an identifier
3301           if we're in a my declaration
3302               croak if they tried to say my($foo::bar)
3303               build the ops for a my() declaration
3304           if it's an access to a my() variable
3305               are we in a sort block?
3306                   croak if my($a); $a <=> $b
3307               build ops for access to a my() variable
3308           if in a dq string, and they've said @foo and we can't find @foo
3309               croak
3310           build ops for a bareword
3311       if we already built the token before, use it.
3312 */
3313
3314
3315 #ifdef __SC__
3316 #pragma segment Perl_yylex
3317 #endif
3318 int
3319 Perl_yylex(pTHX)
3320 {
3321     dVAR;
3322     register char *s = PL_bufptr;
3323     register char *d;
3324     STRLEN len;
3325     bool bof = FALSE;
3326
3327     /* orig_keyword, gvp, and gv are initialized here because
3328      * jump to the label just_a_word_zero can bypass their
3329      * initialization later. */
3330     I32 orig_keyword = 0;
3331     GV *gv = NULL;
3332     GV **gvp = NULL;
3333
3334     DEBUG_T( {
3335         SV* tmp = newSVpvs("");
3336         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3337             (IV)CopLINE(PL_curcop),
3338             lex_state_names[PL_lex_state],
3339             exp_name[PL_expect],
3340             pv_display(tmp, s, strlen(s), 0, 60));
3341         SvREFCNT_dec(tmp);
3342     } );
3343     /* check if there's an identifier for us to look at */
3344     if (PL_pending_ident)
3345         return REPORT(S_pending_ident(aTHX));
3346
3347     /* no identifier pending identification */
3348
3349     switch (PL_lex_state) {
3350 #ifdef COMMENTARY
3351     case LEX_NORMAL:            /* Some compilers will produce faster */
3352     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3353         break;
3354 #endif
3355
3356     /* when we've already built the next token, just pull it out of the queue */
3357     case LEX_KNOWNEXT:
3358 #ifdef PERL_MAD
3359         PL_lasttoke--;
3360         pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3361         if (PL_madskills) {
3362             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3363             PL_nexttoke[PL_lasttoke].next_mad = 0;
3364             if (PL_thismad && PL_thismad->mad_key == '_') {
3365                 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3366                 PL_thismad->mad_val = 0;
3367                 mad_free(PL_thismad);
3368                 PL_thismad = 0;
3369             }
3370         }
3371         if (!PL_lasttoke) {
3372             PL_lex_state = PL_lex_defer;
3373             PL_expect = PL_lex_expect;
3374             PL_lex_defer = LEX_NORMAL;
3375             if (!PL_nexttoke[PL_lasttoke].next_type)
3376                 return yylex();
3377         }
3378 #else
3379         PL_nexttoke--;
3380         pl_yylval = PL_nextval[PL_nexttoke];
3381         if (!PL_nexttoke) {
3382             PL_lex_state = PL_lex_defer;
3383             PL_expect = PL_lex_expect;
3384             PL_lex_defer = LEX_NORMAL;
3385         }
3386 #endif
3387 #ifdef PERL_MAD
3388         /* FIXME - can these be merged?  */
3389         return(PL_nexttoke[PL_lasttoke].next_type);
3390 #else
3391         return REPORT(PL_nexttype[PL_nexttoke]);
3392 #endif
3393
3394     /* interpolated case modifiers like \L \U, including \Q and \E.
3395        when we get here, PL_bufptr is at the \
3396     */
3397     case LEX_INTERPCASEMOD:
3398 #ifdef DEBUGGING
3399         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3400             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3401 #endif
3402         /* handle \E or end of string */
3403         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3404             /* if at a \E */
3405             if (PL_lex_casemods) {
3406                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3407                 PL_lex_casestack[PL_lex_casemods] = '\0';
3408
3409                 if (PL_bufptr != PL_bufend
3410                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3411                     PL_bufptr += 2;
3412                     PL_lex_state = LEX_INTERPCONCAT;
3413 #ifdef PERL_MAD
3414                     if (PL_madskills)
3415                         PL_thistoken = newSVpvs("\\E");
3416 #endif
3417                 }
3418                 return REPORT(')');
3419             }
3420 #ifdef PERL_MAD
3421             while (PL_bufptr != PL_bufend &&
3422               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3423                 if (!PL_thiswhite)
3424                     PL_thiswhite = newSVpvs("");
3425                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3426                 PL_bufptr += 2;
3427             }
3428 #else
3429             if (PL_bufptr != PL_bufend)
3430                 PL_bufptr += 2;
3431 #endif
3432             PL_lex_state = LEX_INTERPCONCAT;
3433             return yylex();
3434         }
3435         else {
3436             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3437               "### Saw case modifier\n"); });
3438             s = PL_bufptr + 1;
3439             if (s[1] == '\\' && s[2] == 'E') {
3440 #ifdef PERL_MAD
3441                 if (!PL_thiswhite)
3442                     PL_thiswhite = newSVpvs("");
3443                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3444 #endif
3445                 PL_bufptr = s + 3;
3446                 PL_lex_state = LEX_INTERPCONCAT;
3447                 return yylex();
3448             }
3449             else {
3450                 I32 tmp;
3451                 if (!PL_madskills) /* when just compiling don't need correct */
3452                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3453                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3454                 if ((*s == 'L' || *s == 'U') &&
3455                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3456                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3457                     return REPORT(')');
3458                 }
3459                 if (PL_lex_casemods > 10)
3460                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3461                 PL_lex_casestack[PL_lex_casemods++] = *s;
3462                 PL_lex_casestack[PL_lex_casemods] = '\0';
3463                 PL_lex_state = LEX_INTERPCONCAT;
3464                 start_force(PL_curforce);
3465                 NEXTVAL_NEXTTOKE.ival = 0;
3466                 force_next('(');
3467                 start_force(PL_curforce);
3468                 if (*s == 'l')
3469                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3470                 else if (*s == 'u')
3471                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3472                 else if (*s == 'L')
3473                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3474                 else if (*s == 'U')
3475                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3476                 else if (*s == 'Q')
3477                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3478                 else
3479                     Perl_croak(aTHX_ "panic: yylex");
3480                 if (PL_madskills) {
3481                     SV* const tmpsv = newSVpvs("\\ ");
3482                     /* replace the space with the character we want to escape
3483                      */
3484                     SvPVX(tmpsv)[1] = *s;
3485                     curmad('_', tmpsv);
3486                 }
3487                 PL_bufptr = s + 1;
3488             }
3489             force_next(FUNC);
3490             if (PL_lex_starts) {
3491                 s = PL_bufptr;
3492                 PL_lex_starts = 0;
3493 #ifdef PERL_MAD
3494                 if (PL_madskills) {
3495                     if (PL_thistoken)
3496                         sv_free(PL_thistoken);
3497                     PL_thistoken = newSVpvs("");
3498                 }
3499 #endif
3500                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3501                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3502                     OPERATOR(',');
3503                 else
3504                     Aop(OP_CONCAT);
3505             }
3506             else
3507                 return yylex();
3508         }
3509
3510     case LEX_INTERPPUSH:
3511         return REPORT(sublex_push());
3512
3513     case LEX_INTERPSTART:
3514         if (PL_bufptr == PL_bufend)
3515             return REPORT(sublex_done());
3516         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3517               "### Interpolated variable\n"); });
3518         PL_expect = XTERM;
3519         PL_lex_dojoin = (*PL_bufptr == '@');
3520         PL_lex_state = LEX_INTERPNORMAL;
3521         if (PL_lex_dojoin) {
3522             start_force(PL_curforce);
3523             NEXTVAL_NEXTTOKE.ival = 0;
3524             force_next(',');
3525             start_force(PL_curforce);
3526             force_ident("\"", '$');
3527             start_force(PL_curforce);
3528             NEXTVAL_NEXTTOKE.ival = 0;
3529             force_next('$');
3530             start_force(PL_curforce);
3531             NEXTVAL_NEXTTOKE.ival = 0;
3532             force_next('(');
3533             start_force(PL_curforce);
3534             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3535             force_next(FUNC);
3536         }
3537         if (PL_lex_starts++) {
3538             s = PL_bufptr;
3539 #ifdef PERL_MAD
3540             if (PL_madskills) {
3541                 if (PL_thistoken)
3542                     sv_free(PL_thistoken);
3543                 PL_thistoken = newSVpvs("");
3544             }
3545 #endif
3546             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3547             if (!PL_lex_casemods && PL_lex_inpat)
3548                 OPERATOR(',');
3549             else
3550                 Aop(OP_CONCAT);
3551         }
3552         return yylex();
3553
3554     case LEX_INTERPENDMAYBE:
3555         if (intuit_more(PL_bufptr)) {
3556             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3557             break;
3558         }
3559         /* FALL THROUGH */
3560
3561     case LEX_INTERPEND:
3562         if (PL_lex_dojoin) {
3563             PL_lex_dojoin = FALSE;
3564             PL_lex_state = LEX_INTERPCONCAT;
3565 #ifdef PERL_MAD
3566             if (PL_madskills) {
3567                 if (PL_thistoken)
3568                     sv_free(PL_thistoken);
3569                 PL_thistoken = newSVpvs("");
3570             }
3571 #endif
3572             return REPORT(')');
3573         }
3574         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3575             && SvEVALED(PL_lex_repl))
3576         {
3577             if (PL_bufptr != PL_bufend)
3578                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3579             PL_lex_repl = NULL;
3580         }
3581         /* FALLTHROUGH */
3582     case LEX_INTERPCONCAT:
3583 #ifdef DEBUGGING
3584         if (PL_lex_brackets)
3585             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3586 #endif
3587         if (PL_bufptr == PL_bufend)
3588             return REPORT(sublex_done());
3589
3590         if (SvIVX(PL_linestr) == '\'') {
3591             SV *sv = newSVsv(PL_linestr);
3592             if (!PL_lex_inpat)
3593                 sv = tokeq(sv);
3594             else if ( PL_hints & HINT_NEW_RE )
3595                 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3596             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3597             s = PL_bufend;
3598         }
3599         else {
3600             s = scan_const(PL_bufptr);
3601             if (*s == '\\')
3602                 PL_lex_state = LEX_INTERPCASEMOD;
3603             else
3604                 PL_lex_state = LEX_INTERPSTART;
3605         }
3606
3607         if (s != PL_bufptr) {
3608             start_force(PL_curforce);
3609             if (PL_madskills) {
3610                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3611             }
3612             NEXTVAL_NEXTTOKE = pl_yylval;
3613             PL_expect = XTERM;
3614             force_next(THING);
3615             if (PL_lex_starts++) {
3616 #ifdef PERL_MAD
3617                 if (PL_madskills) {
3618                     if (PL_thistoken)
3619                         sv_free(PL_thistoken);
3620                     PL_thistoken = newSVpvs("");
3621                 }
3622 #endif
3623                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3624                 if (!PL_lex_casemods && PL_lex_inpat)
3625                     OPERATOR(',');
3626                 else
3627                     Aop(OP_CONCAT);
3628             }
3629             else {
3630                 PL_bufptr = s;
3631                 return yylex();
3632             }
3633         }
3634
3635         return yylex();
3636     case LEX_FORMLINE:
3637         PL_lex_state = LEX_NORMAL;
3638         s = scan_formline(PL_bufptr);
3639         if (!PL_lex_formbrack)
3640             goto rightbracket;
3641         OPERATOR(';');
3642     }
3643
3644     s = PL_bufptr;
3645     PL_oldoldbufptr = PL_oldbufptr;
3646     PL_oldbufptr = s;
3647
3648   retry:
3649 #ifdef PERL_MAD
3650     if (PL_thistoken) {
3651         sv_free(PL_thistoken);
3652         PL_thistoken = 0;
3653     }
3654     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3655 #endif
3656     switch (*s) {
3657     default:
3658         if (isIDFIRST_lazy_if(s,UTF))
3659             goto keylookup;
3660         len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3661         Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
3662     case 4:
3663     case 26:
3664         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3665     case 0:
3666 #ifdef PERL_MAD
3667         if (PL_madskills)
3668             PL_faketokens = 0;
3669 #endif
3670         if (!PL_rsfp) {
3671             PL_last_uni = 0;
3672             PL_last_lop = 0;
3673             if (PL_lex_brackets) {
3674                 yyerror((const char *)
3675                         (PL_lex_formbrack
3676                          ? "Format not terminated"
3677                          : "Missing right curly or square bracket"));
3678             }
3679             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3680                         "### Tokener got EOF\n");
3681             } );
3682             TOKEN(0);
3683         }
3684         if (s++ < PL_bufend)
3685             goto retry;                 /* ignore stray nulls */
3686         PL_last_uni = 0;
3687         PL_last_lop = 0;
3688         if (!PL_in_eval && !PL_preambled) {
3689             PL_preambled = TRUE;
3690 #ifdef PERL_MAD
3691             if (PL_madskills)
3692                 PL_faketokens = 1;
3693 #endif
3694             if (PL_perldb) {
3695                 /* Generate a string of Perl code to load the debugger.
3696                  * If PERL5DB is set, it will return the contents of that,
3697                  * otherwise a compile-time require of perl5db.pl.  */
3698
3699                 const char * const pdb = PerlEnv_getenv("PERL5DB");
3700
3701                 if (pdb) {
3702                     sv_setpv(PL_linestr, pdb);
3703                     sv_catpvs(PL_linestr,";");
3704                 } else {
3705                     SETERRNO(0,SS_NORMAL);
3706                     sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3707                 }
3708             } else
3709                 sv_setpvs(PL_linestr,"");
3710             if (PL_preambleav) {
3711                 SV **svp = AvARRAY(PL_preambleav);
3712                 SV **const end = svp + AvFILLp(PL_preambleav);
3713                 while(svp <= end) {
3714                     sv_catsv(PL_linestr, *svp);
3715                     ++svp;
3716                     sv_catpvs(PL_linestr, ";");
3717                 }
3718                 sv_free(MUTABLE_SV(PL_preambleav));
3719                 PL_preambleav = NULL;
3720             }
3721             if (PL_minus_E)
3722                 sv_catpvs(PL_linestr,
3723                           "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3724             if (PL_minus_n || PL_minus_p) {
3725                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3726                 if (PL_minus_l)
3727                     sv_catpvs(PL_linestr,"chomp;");
3728                 if (PL_minus_a) {
3729                     if (PL_minus_F) {
3730                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3731                              || *PL_splitstr == '"')
3732                               && strchr(PL_splitstr + 1, *PL_splitstr))
3733                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3734                         else {
3735                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3736                                bytes can be used as quoting characters.  :-) */
3737                             const char *splits = PL_splitstr;
3738                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3739                             do {
3740                                 /* Need to \ \s  */
3741                                 if (*splits == '\\')
3742                                     sv_catpvn(PL_linestr, splits, 1);
3743                                 sv_catpvn(PL_linestr, splits, 1);
3744                             } while (*splits++);
3745                             /* This loop will embed the trailing NUL of
3746                                PL_linestr as the last thing it does before
3747                                terminating.  */
3748                             sv_catpvs(PL_linestr, ");");
3749                         }
3750                     }
3751                     else
3752                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3753                 }
3754             }
3755             sv_catpvs(PL_linestr, "\n");
3756             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3757             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3758             PL_last_lop = PL_last_uni = NULL;
3759             if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3760                 update_debugger_info(PL_linestr, NULL, 0);
3761             goto retry;
3762         }
3763         do {
3764             bof = PL_rsfp ? TRUE : FALSE;
3765             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3766               fake_eof:
3767 #ifdef PERL_MAD
3768                 PL_realtokenstart = -1;
3769 #endif
3770                 if (PL_rsfp) {
3771                     if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3772                         PerlIO_clearerr(PL_rsfp);
3773                     else
3774                         (void)PerlIO_close(PL_rsfp);
3775                     PL_rsfp = NULL;
3776                     PL_doextract = FALSE;
3777                 }
3778                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3779 #ifdef PERL_MAD
3780                     if (PL_madskills)
3781                         PL_faketokens = 1;
3782 #endif
3783                     if (PL_minus_p)
3784                         sv_setpvs(PL_linestr, ";}continue{print;}");
3785                     else
3786                         sv_setpvs(PL_linestr, ";}");
3787                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3788                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3789                     PL_last_lop = PL_last_uni = NULL;
3790                     PL_minus_n = PL_minus_p = 0;
3791                     goto retry;
3792                 }
3793                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3794                 PL_last_lop = PL_last_uni = NULL;
3795                 sv_setpvs(PL_linestr,"");
3796                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3797             }
3798             /* If it looks like the start of a BOM or raw UTF-16,
3799              * check if it in fact is. */
3800             else if (bof &&
3801                      (*s == 0 ||
3802                       *(U8*)s == 0xEF ||
3803                       *(U8*)s >= 0xFE ||
3804                       s[1] == 0)) {
3805 #ifdef PERLIO_IS_STDIO
3806 #  ifdef __GNU_LIBRARY__
3807 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3808 #      define FTELL_FOR_PIPE_IS_BROKEN
3809 #    endif
3810 #  else
3811 #    ifdef __GLIBC__
3812 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3813 #        define FTELL_FOR_PIPE_IS_BROKEN
3814 #      endif
3815 #    endif
3816 #  endif
3817 #endif
3818                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3819                 if (bof) {
3820                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3821                     s = swallow_bom((U8*)s);
3822                 }
3823             }
3824             if (PL_doextract) {
3825                 /* Incest with pod. */
3826 #ifdef PERL_MAD
3827                 if (PL_madskills)
3828                     sv_catsv(PL_thiswhite, PL_linestr);
3829 #endif
3830                 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3831                     sv_setpvs(PL_linestr, "");
3832                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3833                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3834                     PL_last_lop = PL_last_uni = NULL;
3835                     PL_doextract = FALSE;
3836                 }
3837             }
3838             incline(s);
3839         } while (PL_doextract);
3840         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3841         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3842             update_debugger_info(PL_linestr, NULL, 0);
3843         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3844         PL_last_lop = PL_last_uni = NULL;
3845         if (CopLINE(PL_curcop) == 1) {
3846             while (s < PL_bufend && isSPACE(*s))
3847                 s++;
3848             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3849                 s++;
3850 #ifdef PERL_MAD
3851             if (PL_madskills)
3852                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3853 #endif
3854             d = NULL;
3855             if (!PL_in_eval) {
3856                 if (*s == '#' && *(s+1) == '!')
3857                     d = s + 2;
3858 #ifdef ALTERNATE_SHEBANG
3859                 else {
3860                     static char const as[] = ALTERNATE_SHEBANG;
3861                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3862                         d = s + (sizeof(as) - 1);
3863                 }
3864 #endif /* ALTERNATE_SHEBANG */
3865             }
3866             if (d) {
3867                 char *ipath;
3868                 char *ipathend;
3869
3870                 while (isSPACE(*d))
3871                     d++;
3872                 ipath = d;
3873                 while (*d && !isSPACE(*d))
3874                     d++;
3875                 ipathend = d;
3876
3877 #ifdef ARG_ZERO_IS_SCRIPT
3878                 if (ipathend > ipath) {
3879                     /*
3880                      * HP-UX (at least) sets argv[0] to the script name,
3881                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3882                      * at least, set argv[0] to the basename of the Perl
3883                      * interpreter. So, having found "#!", we'll set it right.
3884                      */
3885                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3886                                                     SVt_PV)); /* $^X */
3887                     assert(SvPOK(x) || SvGMAGICAL(x));
3888                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3889                         sv_setpvn(x, ipath, ipathend - ipath);
3890                         SvSETMAGIC(x);
3891                     }
3892                     else {
3893                         STRLEN blen;
3894                         STRLEN llen;
3895                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3896                         const char * const lstart = SvPV_const(x,llen);
3897                         if (llen < blen) {
3898                             bstart += blen - llen;
3899                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3900                                 sv_setpvn(x, ipath, ipathend - ipath);
3901                                 SvSETMAGIC(x);
3902                             }
3903                         }
3904                     }
3905                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3906                 }
3907 #endif /* ARG_ZERO_IS_SCRIPT */
3908
3909                 /*
3910                  * Look for options.
3911                  */
3912                 d = instr(s,"perl -");
3913                 if (!d) {
3914                     d = instr(s,"perl");
3915 #if defined(DOSISH)
3916                     /* avoid getting into infinite loops when shebang
3917                      * line contains "Perl" rather than "perl" */
3918                     if (!d) {
3919                         for (d = ipathend-4; d >= ipath; --d) {
3920                             if ((*d == 'p' || *d == 'P')
3921                                 && !ibcmp(d, "perl", 4))
3922                             {
3923                                 break;
3924                             }
3925                         }
3926                         if (d < ipath)
3927                             d = NULL;
3928                     }
3929 #endif
3930                 }
3931 #ifdef ALTERNATE_SHEBANG
3932                 /*
3933                  * If the ALTERNATE_SHEBANG on this system starts with a
3934                  * character that can be part of a Perl expression, then if
3935                  * we see it but not "perl", we're probably looking at the
3936                  * start of Perl code, not a request to hand off to some
3937                  * other interpreter.  Similarly, if "perl" is there, but
3938                  * not in the first 'word' of the line, we assume the line
3939                  * contains the start of the Perl program.
3940                  */
3941                 if (d && *s != '#') {
3942                     const char *c = ipath;
3943                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3944                         c++;
3945                     if (c < d)
3946                         d = NULL;       /* "perl" not in first word; ignore */
3947                     else
3948                         *s = '#';       /* Don't try to parse shebang line */
3949                 }
3950 #endif /* ALTERNATE_SHEBANG */
3951 #ifndef MACOS_TRADITIONAL
3952                 if (!d &&
3953                     *s == '#' &&
3954                     ipathend > ipath &&
3955                     !PL_minus_c &&
3956                     !instr(s,"indir") &&
3957                     instr(PL_origargv[0],"perl"))
3958                 {
3959                     dVAR;
3960                     char **newargv;
3961
3962                     *ipathend = '\0';
3963                     s = ipathend + 1;
3964                     while (s < PL_bufend && isSPACE(*s))
3965                         s++;
3966                     if (s < PL_bufend) {
3967                         Newxz(newargv,PL_origargc+3,char*);
3968                         newargv[1] = s;
3969                         while (s < PL_bufend && !isSPACE(*s))
3970                             s++;
3971                         *s = '\0';
3972                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3973                     }
3974                     else
3975                         newargv = PL_origargv;
3976                     newargv[0] = ipath;
3977                     PERL_FPU_PRE_EXEC
3978                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3979                     PERL_FPU_POST_EXEC
3980                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3981                 }
3982 #endif
3983                 if (d) {
3984                     while (*d && !isSPACE(*d))
3985                         d++;
3986                     while (SPACE_OR_TAB(*d))
3987                         d++;
3988
3989                     if (*d++ == '-') {
3990                         const bool switches_done = PL_doswitches;
3991                         const U32 oldpdb = PL_perldb;
3992                         const bool oldn = PL_minus_n;
3993                         const bool oldp = PL_minus_p;
3994                         const char *d1 = d;
3995
3996                         do {
3997                             if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
3998                                 const char * const m = d1;
3999                                 while (*d1 && !isSPACE(*d1))
4000                                     d1++;
4001                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4002                                       (int)(d1 - m), m);
4003                             }
4004                             d1 = moreswitches(d1);
4005                         } while (d1);
4006                         if (PL_doswitches && !switches_done) {
4007                             int argc = PL_origargc;
4008                             char **argv = PL_origargv;
4009                             do {
4010                                 argc--,argv++;
4011                             } while (argc && argv[0][0] == '-' && argv[0][1]);
4012                             init_argv_symbols(argc,argv);
4013                         }
4014                         if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4015                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4016                               /* if we have already added "LINE: while (<>) {",
4017                                  we must not do it again */
4018                         {
4019                             sv_setpvs(PL_linestr, "");
4020                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4021                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4022                             PL_last_lop = PL_last_uni = NULL;
4023                             PL_preambled = FALSE;
4024                             if (PERLDB_LINE || PERLDB_SAVESRC)
4025                                 (void)gv_fetchfile(PL_origfilename);
4026                             goto retry;
4027                         }
4028                     }
4029                 }
4030             }
4031         }
4032         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4033             PL_bufptr = s;
4034             PL_lex_state = LEX_FORMLINE;
4035             return yylex();
4036         }
4037         goto retry;
4038     case '\r':
4039 #ifdef PERL_STRICT_CR
4040         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4041         Perl_croak(aTHX_
4042       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4043 #endif
4044     case ' ': case '\t': case '\f': case 013:
4045 #ifdef MACOS_TRADITIONAL
4046     case '\312':
4047 #endif
4048 #ifdef PERL_MAD
4049         PL_realtokenstart = -1;
4050         if (!PL_thiswhite)
4051             PL_thiswhite = newSVpvs("");
4052         sv_catpvn(PL_thiswhite, s, 1);
4053 #endif
4054         s++;
4055         goto retry;
4056     case '#':
4057     case '\n':
4058 #ifdef PERL_MAD
4059         PL_realtokenstart = -1;
4060         if (PL_madskills)
4061             PL_faketokens = 0;
4062 #endif
4063         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4064             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4065                 /* handle eval qq[#line 1 "foo"\n ...] */
4066                 CopLINE_dec(PL_curcop);
4067                 incline(s);
4068             }
4069             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4070                 s = SKIPSPACE0(s);
4071                 if (!PL_in_eval || PL_rsfp)
4072                     incline(s);
4073             }
4074             else {
4075                 d = s;
4076                 while (d < PL_bufend && *d != '\n')
4077                     d++;
4078                 if (d < PL_bufend)
4079                     d++;
4080                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4081                   Perl_croak(aTHX_ "panic: input overflow");
4082 #ifdef PERL_MAD
4083                 if (PL_madskills)
4084                     PL_thiswhite = newSVpvn(s, d - s);
4085 #endif
4086                 s = d;
4087                 incline(s);
4088             }
4089             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4090                 PL_bufptr = s;
4091                 PL_lex_state = LEX_FORMLINE;
4092                 return yylex();
4093             }
4094         }
4095         else {
4096 #ifdef PERL_MAD
4097             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4098                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4099                     PL_faketokens = 0;
4100                     s = SKIPSPACE0(s);
4101                     TOKEN(PEG); /* make sure any #! line is accessible */
4102                 }
4103                 s = SKIPSPACE0(s);
4104             }
4105             else {
4106 /*              if (PL_madskills && PL_lex_formbrack) { */
4107                     d = s;
4108                     while (d < PL_bufend && *d != '\n')
4109                         d++;
4110                     if (d < PL_bufend)
4111                         d++;
4112                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4113                       Perl_croak(aTHX_ "panic: input overflow");
4114                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4115                         if (!PL_thiswhite)
4116                             PL_thiswhite = newSVpvs("");
4117                         if (CopLINE(PL_curcop) == 1) {
4118                             sv_setpvs(PL_thiswhite, "");
4119                             PL_faketokens = 0;
4120                         }
4121                         sv_catpvn(PL_thiswhite, s, d - s);
4122                     }
4123                     s = d;
4124 /*              }
4125                 *s = '\0';
4126                 PL_bufend = s; */
4127             }
4128 #else
4129             *s = '\0';
4130             PL_bufend = s;
4131 #endif
4132         }
4133         goto retry;
4134     case '-':
4135         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4136             I32 ftst = 0;
4137             char tmp;
4138
4139             s++;
4140             PL_bufptr = s;
4141             tmp = *s++;
4142
4143             while (s < PL_bufend && SPACE_OR_TAB(*s))
4144                 s++;
4145
4146             if (strnEQ(s,"=>",2)) {
4147                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4148                 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4149                 OPERATOR('-');          /* unary minus */
4150             }
4151             PL_last_uni = PL_oldbufptr;
4152             switch (tmp) {
4153             case 'r': ftst = OP_FTEREAD;        break;
4154             case 'w': ftst = OP_FTEWRITE;       break;
4155             case 'x': ftst = OP_FTEEXEC;        break;
4156             case 'o': ftst = OP_FTEOWNED;       break;
4157             case 'R': ftst = OP_FTRREAD;        break;
4158             case 'W': ftst = OP_FTRWRITE;       break;
4159             case 'X': ftst = OP_FTREXEC;        break;
4160             case 'O': ftst = OP_FTROWNED;       break;
4161             case 'e': ftst = OP_FTIS;           break;
4162             case 'z': ftst = OP_FTZERO;         break;
4163             case 's': ftst = OP_FTSIZE;         break;
4164             case 'f': ftst = OP_FTFILE;         break;
4165             case 'd': ftst = OP_FTDIR;          break;
4166             case 'l': ftst = OP_FTLINK;         break;
4167             case 'p': ftst = OP_FTPIPE;         break;
4168             case 'S': ftst = OP_FTSOCK;         break;
4169             case 'u': ftst = OP_FTSUID;         break;
4170             case 'g': ftst = OP_FTSGID;         break;
4171             case 'k': ftst = OP_FTSVTX;         break;
4172             case 'b': ftst = OP_FTBLK;          break;
4173             case 'c': ftst = OP_FTCHR;          break;
4174             case 't': ftst = OP_FTTTY;          break;
4175             case 'T': ftst = OP_FTTEXT;         break;
4176             case 'B': ftst = OP_FTBINARY;       break;
4177             case 'M': case 'A': case 'C':
4178                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4179                 switch (tmp) {
4180                 case 'M': ftst = OP_FTMTIME;    break;
4181                 case 'A': ftst = OP_FTATIME;    break;
4182                 case 'C': ftst = OP_FTCTIME;    break;
4183                 default:                        break;
4184                 }
4185                 break;
4186             default:
4187                 break;
4188             }
4189             if (ftst) {
4190                 PL_last_lop_op = (OPCODE)ftst;
4191                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4192                         "### Saw file test %c\n", (int)tmp);
4193                 } );
4194                 FTST(ftst);
4195             }
4196             else {
4197                 /* Assume it was a minus followed by a one-letter named
4198                  * subroutine call (or a -bareword), then. */
4199                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4200                         "### '-%c' looked like a file test but was not\n",
4201                         (int) tmp);
4202                 } );
4203                 s = --PL_bufptr;
4204             }
4205         }
4206         {
4207             const char tmp = *s++;
4208             if (*s == tmp) {
4209                 s++;
4210                 if (PL_expect == XOPERATOR)
4211                     TERM(POSTDEC);
4212                 else
4213                     OPERATOR(PREDEC);
4214             }
4215             else if (*s == '>') {
4216                 s++;
4217                 s = SKIPSPACE1(s);
4218                 if (isIDFIRST_lazy_if(s,UTF)) {
4219                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4220                     TOKEN(ARROW);
4221                 }
4222                 else if (*s == '$')
4223                     OPERATOR(ARROW);
4224                 else
4225                     TERM(ARROW);
4226             }
4227             if (PL_expect == XOPERATOR)
4228                 Aop(OP_SUBTRACT);
4229             else {
4230                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4231                     check_uni();
4232                 OPERATOR('-');          /* unary minus */
4233             }
4234         }
4235
4236     case '+':
4237         {
4238             const char tmp = *s++;
4239             if (*s == tmp) {
4240                 s++;
4241                 if (PL_expect == XOPERATOR)
4242                     TERM(POSTINC);
4243                 else
4244                     OPERATOR(PREINC);
4245             }
4246             if (PL_expect == XOPERATOR)
4247                 Aop(OP_ADD);
4248             else {
4249                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4250                     check_uni();
4251                 OPERATOR('+');
4252             }
4253         }
4254
4255     case '*':
4256         if (PL_expect != XOPERATOR) {
4257             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4258             PL_expect = XOPERATOR;
4259             force_ident(PL_tokenbuf, '*');
4260             if (!*PL_tokenbuf)
4261                 PREREF('*');
4262             TERM('*');
4263         }
4264         s++;
4265         if (*s == '*') {
4266             s++;
4267             PWop(OP_POW);
4268         }
4269         Mop(OP_MULTIPLY);
4270
4271     case '%':
4272         if (PL_expect == XOPERATOR) {
4273             ++s;
4274             Mop(OP_MODULO);
4275         }
4276         PL_tokenbuf[0] = '%';
4277         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4278                 sizeof PL_tokenbuf - 1, FALSE);
4279         if (!PL_tokenbuf[1]) {
4280             PREREF('%');
4281         }
4282         PL_pending_ident = '%';
4283         TERM('%');
4284
4285     case '^':
4286         s++;
4287         BOop(OP_BIT_XOR);
4288     case '[':
4289         PL_lex_brackets++;
4290         /* FALL THROUGH */
4291     case '~':
4292         if (s[1] == '~'
4293             && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4294         {
4295             s += 2;
4296             Eop(OP_SMARTMATCH);
4297         }
4298     case ',':
4299         {
4300             const char tmp = *s++;
4301             OPERATOR(tmp);
4302         }
4303     case ':':
4304         if (s[1] == ':') {
4305             len = 0;
4306             goto just_a_word_zero_gv;
4307         }
4308         s++;
4309         switch (PL_expect) {
4310             OP *attrs;
4311 #ifdef PERL_MAD
4312             I32 stuffstart;
4313 #endif
4314         case XOPERATOR:
4315             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4316                 break;
4317             PL_bufptr = s;      /* update in case we back off */
4318             goto grabattrs;
4319         case XATTRBLOCK:
4320             PL_expect = XBLOCK;
4321             goto grabattrs;
4322         case XATTRTERM:
4323             PL_expect = XTERMBLOCK;
4324          grabattrs:
4325 #ifdef PERL_MAD
4326             stuffstart = s - SvPVX(PL_linestr) - 1;
4327 #endif
4328             s = PEEKSPACE(s);
4329             attrs = NULL;
4330             while (isIDFIRST_lazy_if(s,UTF)) {
4331                 I32 tmp;
4332                 SV *sv;
4333                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4334                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4335                     if (tmp < 0) tmp = -tmp;
4336                     switch (tmp) {
4337                     case KEY_or:
4338                     case KEY_and:
4339                     case KEY_for:
4340                     case KEY_unless:
4341                     case KEY_if:
4342                     case KEY_while:
4343                     case KEY_until:
4344                         goto got_attrs;
4345                     default:
4346                         break;
4347                     }
4348                 }
4349                 sv = newSVpvn(s, len);
4350                 if (*d == '(') {
4351                     d = scan_str(d,TRUE,TRUE);
4352                     if (!d) {
4353                         /* MUST advance bufptr here to avoid bogus
4354                            "at end of line" context messages from yyerror().
4355                          */
4356                         PL_bufptr = s + len;
4357                         yyerror("Unterminated attribute parameter in attribute list");
4358                         if (attrs)
4359                             op_free(attrs);
4360                         sv_free(sv);
4361                         return REPORT(0);       /* EOF indicator */
4362                     }
4363                 }
4364                 if (PL_lex_stuff) {
4365                     sv_catsv(sv, PL_lex_stuff);
4366                     attrs = append_elem(OP_LIST, attrs,
4367                                         newSVOP(OP_CONST, 0, sv));
4368                     SvREFCNT_dec(PL_lex_stuff);
4369                     PL_lex_stuff = NULL;
4370                 }
4371                 else {
4372                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4373                         sv_free(sv);
4374                         if (PL_in_my == KEY_our) {
4375 #ifdef USE_ITHREADS
4376                             GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
4377 #else
4378                             /* skip to avoid loading attributes.pm */
4379 #endif
4380                             deprecate(":unique");
4381                         }
4382                         else
4383                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4384                     }
4385
4386                     /* NOTE: any CV attrs applied here need to be part of
4387                        the CVf_BUILTIN_ATTRS define in cv.h! */
4388                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4389                         sv_free(sv);
4390                         CvLVALUE_on(PL_compcv);
4391                     }
4392                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4393                         sv_free(sv);
4394                         CvLOCKED_on(PL_compcv);
4395                     }
4396                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4397                         sv_free(sv);
4398                         CvMETHOD_on(PL_compcv);
4399                     }
4400                     /* After we've set the flags, it could be argued that
4401                        we don't need to do the attributes.pm-based setting
4402                        process, and shouldn't bother appending recognized
4403                        flags.  To experiment with that, uncomment the
4404                        following "else".  (Note that's already been
4405                        uncommented.  That keeps the above-applied built-in
4406                        attributes from being intercepted (and possibly
4407                        rejected) by a package's attribute routines, but is
4408                        justified by the performance win for the common case
4409                        of applying only built-in attributes.) */
4410                     else
4411                         attrs = append_elem(OP_LIST, attrs,
4412                                             newSVOP(OP_CONST, 0,
4413                                                     sv));
4414                 }
4415                 s = PEEKSPACE(d);
4416                 if (*s == ':' && s[1] != ':')
4417                     s = PEEKSPACE(s+1);
4418                 else if (s == d)
4419                     break;      /* require real whitespace or :'s */
4420                 /* XXX losing whitespace on sequential attributes here */
4421             }
4422             {
4423                 const char tmp
4424                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4425                 if (*s != ';' && *s != '}' && *s != tmp
4426                     && (tmp != '=' || *s != ')')) {
4427                     const char q = ((*s == '\'') ? '"' : '\'');
4428                     /* If here for an expression, and parsed no attrs, back
4429                        off. */
4430                     if (tmp == '=' && !attrs) {
4431                         s = PL_bufptr;
4432                         break;
4433                     }
4434                     /* MUST advance bufptr here to avoid bogus "at end of line"
4435                        context messages from yyerror().
4436                     */
4437                     PL_bufptr = s;
4438                     yyerror( (const char *)
4439                              (*s
4440                               ? Perl_form(aTHX_ "Invalid separator character "
4441                                           "%c%c%c in attribute list", q, *s, q)
4442                               : "Unterminated attribute list" ) );
4443                     if (attrs)
4444                         op_free(attrs);
4445                     OPERATOR(':');
4446                 }
4447             }
4448         got_attrs:
4449             if (attrs) {
4450                 start_force(PL_curforce);
4451                 NEXTVAL_NEXTTOKE.opval = attrs;
4452                 CURMAD('_', PL_nextwhite);
4453                 force_next(THING);
4454             }
4455 #ifdef PERL_MAD
4456             if (PL_madskills) {
4457                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4458                                      (s - SvPVX(PL_linestr)) - stuffstart);
4459             }
4460 #endif
4461             TOKEN(COLONATTR);
4462         }
4463         OPERATOR(':');
4464     case '(':
4465         s++;
4466         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4467             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4468         else
4469             PL_expect = XTERM;
4470         s = SKIPSPACE1(s);
4471         TOKEN('(');
4472     case ';':
4473         CLINE;
4474         {
4475             const char tmp = *s++;
4476             OPERATOR(tmp);
4477         }
4478     case ')':
4479         {
4480             const char tmp = *s++;
4481             s = SKIPSPACE1(s);
4482             if (*s == '{')
4483                 PREBLOCK(tmp);
4484             TERM(tmp);
4485         }
4486     case ']':
4487         s++;
4488         if (PL_lex_brackets <= 0)
4489             yyerror("Unmatched right square bracket");
4490         else
4491             --PL_lex_brackets;
4492         if (PL_lex_state == LEX_INTERPNORMAL) {
4493             if (PL_lex_brackets == 0) {
4494                 if (*s == '-' && s[1] == '>')
4495                     PL_lex_state = LEX_INTERPENDMAYBE;
4496                 else if (*s != '[' && *s != '{')
4497                     PL_lex_state = LEX_INTERPEND;
4498             }
4499         }
4500         TERM(']');
4501     case '{':
4502       leftbracket:
4503         s++;
4504         if (PL_lex_brackets > 100) {
4505             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4506         }
4507         switch (PL_expect) {
4508         case XTERM:
4509             if (PL_lex_formbrack) {
4510                 s--;
4511                 PRETERMBLOCK(DO);
4512             }
4513             if (PL_oldoldbufptr == PL_last_lop)
4514                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4515             else
4516                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4517             OPERATOR(HASHBRACK);
4518         case XOPERATOR:
4519             while (s < PL_bufend && SPACE_OR_TAB(*s))
4520                 s++;
4521             d = s;
4522             PL_tokenbuf[0] = '\0';
4523             if (d < PL_bufend && *d == '-') {
4524                 PL_tokenbuf[0] = '-';
4525                 d++;
4526                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4527                     d++;
4528             }
4529             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4530                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4531                               FALSE, &len);
4532                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4533                     d++;
4534                 if (*d == '}') {
4535                     const char minus = (PL_tokenbuf[0] == '-');
4536                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4537                     if (minus)
4538                         force_next('-');
4539                 }
4540             }
4541             /* FALL THROUGH */
4542         case XATTRBLOCK:
4543         case XBLOCK:
4544             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4545             PL_expect = XSTATE;
4546             break;
4547         case XATTRTERM:
4548         case XTERMBLOCK:
4549             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4550             PL_expect = XSTATE;
4551             break;
4552         default: {
4553                 const char *t;
4554                 if (PL_oldoldbufptr == PL_last_lop)
4555                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4556                 else
4557                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4558                 s = SKIPSPACE1(s);
4559                 if (*s == '}') {
4560                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4561                         PL_expect = XTERM;
4562                         /* This hack is to get the ${} in the message. */
4563                         PL_bufptr = s+1;
4564                         yyerror("syntax error");
4565                         break;
4566                     }
4567                     OPERATOR(HASHBRACK);
4568                 }
4569                 /* This hack serves to disambiguate a pair of curlies
4570                  * as being a block or an anon hash.  Normally, expectation
4571                  * determines that, but in cases where we're not in a
4572                  * position to expect anything in particular (like inside
4573                  * eval"") we have to resolve the ambiguity.  This code
4574                  * covers the case where the first term in the curlies is a
4575                  * quoted string.  Most other cases need to be explicitly
4576                  * disambiguated by prepending a "+" before the opening
4577                  * curly in order to force resolution as an anon hash.
4578                  *
4579                  * XXX should probably propagate the outer expectation
4580                  * into eval"" to rely less on this hack, but that could
4581                  * potentially break current behavior of eval"".
4582                  * GSAR 97-07-21
4583                  */
4584                 t = s;
4585                 if (*s == '\'' || *s == '"' || *s == '`') {
4586                     /* common case: get past first string, handling escapes */
4587                     for (t++; t < PL_bufend && *t != *s;)
4588                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4589                             t++;
4590                     t++;
4591                 }
4592                 else if (*s == 'q') {
4593                     if (++t < PL_bufend
4594                         && (!isALNUM(*t)
4595                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4596                                 && !isALNUM(*t))))
4597                     {
4598                         /* skip q//-like construct */
4599                         const char *tmps;
4600                         char open, close, term;
4601                         I32 brackets = 1;
4602
4603                         while (t < PL_bufend && isSPACE(*t))
4604                             t++;
4605                         /* check for q => */
4606                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4607                             OPERATOR(HASHBRACK);
4608                         }
4609                         term = *t;
4610                         open = term;
4611                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4612                             term = tmps[5];
4613                         close = term;
4614                         if (open == close)
4615                             for (t++; t < PL_bufend; t++) {
4616                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4617                                     t++;
4618                                 else if (*t == open)
4619                                     break;
4620                             }
4621                         else {
4622                             for (t++; t < PL_bufend; t++) {
4623                                 if (*t == '\\' && t+1 < PL_bufend)
4624                                     t++;
4625                                 else if (*t == close && --brackets <= 0)
4626                                     break;
4627                                 else if (*t == open)
4628                                     brackets++;
4629                             }
4630                         }
4631                         t++;
4632                     }
4633                     else
4634                         /* skip plain q word */
4635                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4636                              t += UTF8SKIP(t);
4637                 }
4638                 else if (isALNUM_lazy_if(t,UTF)) {
4639                     t += UTF8SKIP(t);
4640                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4641                          t += UTF8SKIP(t);
4642                 }
4643                 while (t < PL_bufend && isSPACE(*t))
4644                     t++;
4645                 /* if comma follows first term, call it an anon hash */
4646                 /* XXX it could be a comma expression with loop modifiers */
4647                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4648                                    || (*t == '=' && t[1] == '>')))
4649                     OPERATOR(HASHBRACK);
4650                 if (PL_expect == XREF)
4651                     PL_expect = XTERM;
4652                 else {
4653                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4654                     PL_expect = XSTATE;
4655                 }
4656             }
4657             break;
4658         }
4659         pl_yylval.ival = CopLINE(PL_curcop);
4660         if (isSPACE(*s) || *s == '#')
4661             PL_copline = NOLINE;   /* invalidate current command line number */
4662         TOKEN('{');
4663     case '}':
4664       rightbracket:
4665         s++;
4666         if (PL_lex_brackets <= 0)
4667             yyerror("Unmatched right curly bracket");
4668         else
4669             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4670         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4671             PL_lex_formbrack = 0;
4672         if (PL_lex_state == LEX_INTERPNORMAL) {
4673             if (PL_lex_brackets == 0) {
4674                 if (PL_expect & XFAKEBRACK) {
4675                     PL_expect &= XENUMMASK;
4676                     PL_lex_state = LEX_INTERPEND;
4677                     PL_bufptr = s;
4678 #if 0
4679                     if (PL_madskills) {
4680                         if (!PL_thiswhite)
4681                             PL_thiswhite = newSVpvs("");
4682                         sv_catpvs(PL_thiswhite,"}");
4683                     }
4684 #endif
4685                     return yylex();     /* ignore fake brackets */
4686                 }
4687                 if (*s == '-' && s[1] == '>')
4688                     PL_lex_state = LEX_INTERPENDMAYBE;
4689                 else if (*s != '[' && *s != '{')
4690                     PL_lex_state = LEX_INTERPEND;
4691             }
4692         }
4693         if (PL_expect & XFAKEBRACK) {
4694             PL_expect &= XENUMMASK;
4695             PL_bufptr = s;
4696             return yylex();             /* ignore fake brackets */
4697         }
4698         start_force(PL_curforce);
4699         if (PL_madskills) {
4700             curmad('X', newSVpvn(s-1,1));
4701             CURMAD('_', PL_thiswhite);
4702         }
4703         force_next('}');
4704 #ifdef PERL_MAD
4705         if (!PL_thistoken)
4706             PL_thistoken = newSVpvs("");
4707 #endif
4708         TOKEN(';');
4709     case '&':
4710         s++;
4711         if (*s++ == '&')
4712             AOPERATOR(ANDAND);
4713         s--;
4714         if (PL_expect == XOPERATOR) {
4715             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4716                 && isIDFIRST_lazy_if(s,UTF))
4717             {
4718                 CopLINE_dec(PL_curcop);
4719                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4720                 CopLINE_inc(PL_curcop);
4721             }
4722             BAop(OP_BIT_AND);
4723         }
4724
4725         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4726         if (*PL_tokenbuf) {
4727             PL_expect = XOPERATOR;
4728             force_ident(PL_tokenbuf, '&');
4729         }
4730         else
4731             PREREF('&');
4732         pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4733         TERM('&');
4734
4735     case '|':
4736         s++;
4737         if (*s++ == '|')
4738             AOPERATOR(OROR);
4739         s--;
4740         BOop(OP_BIT_OR);
4741     case '=':
4742         s++;
4743         {
4744             const char tmp = *s++;
4745             if (tmp == '=')
4746                 Eop(OP_EQ);
4747             if (tmp == '>')
4748                 OPERATOR(',');
4749             if (tmp == '~')
4750                 PMop(OP_MATCH);
4751             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4752                 && strchr("+-*/%.^&|<",tmp))
4753                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4754                             "Reversed %c= operator",(int)tmp);
4755             s--;
4756             if (PL_expect == XSTATE && isALPHA(tmp) &&
4757                 (s == PL_linestart+1 || s[-2] == '\n') )
4758                 {
4759                     if (PL_in_eval && !PL_rsfp) {
4760                         d = PL_bufend;
4761                         while (s < d) {
4762                             if (*s++ == '\n') {
4763                                 incline(s);
4764                                 if (strnEQ(s,"=cut",4)) {
4765                                     s = strchr(s,'\n');
4766                                     if (s)
4767                                         s++;
4768                                     else
4769                                         s = d;
4770                                     incline(s);
4771                                     goto retry;
4772                                 }
4773                             }
4774                         }
4775                         goto retry;
4776                     }
4777 #ifdef PERL_MAD
4778                     if (PL_madskills) {
4779                         if (!PL_thiswhite)
4780                             PL_thiswhite = newSVpvs("");
4781                         sv_catpvn(PL_thiswhite, PL_linestart,
4782                                   PL_bufend - PL_linestart);
4783                     }
4784 #endif
4785                     s = PL_bufend;
4786                     PL_doextract = TRUE;
4787                     goto retry;
4788                 }
4789         }
4790         if (PL_lex_brackets < PL_lex_formbrack) {
4791             const char *t = s;
4792 #ifdef PERL_STRICT_CR
4793             while (SPACE_OR_TAB(*t))
4794 #else
4795             while (SPACE_OR_TAB(*t) || *t == '\r')
4796 #endif
4797                 t++;
4798             if (*t == '\n' || *t == '#') {
4799                 s--;
4800                 PL_expect = XBLOCK;
4801                 goto leftbracket;
4802             }
4803         }
4804         pl_yylval.ival = 0;
4805         OPERATOR(ASSIGNOP);
4806     case '!':
4807         if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
4808             s += 3;
4809             LOP(OP_DIE,XTERM);
4810         }
4811         s++;
4812         {
4813             const char tmp = *s++;
4814             if (tmp == '=') {
4815                 /* was this !=~ where !~ was meant?
4816                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4817
4818                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4819                     const char *t = s+1;
4820
4821                     while (t < PL_bufend && isSPACE(*t))
4822                         ++t;
4823
4824                     if (*t == '/' || *t == '?' ||
4825                         ((*t == 'm' || *t == 's' || *t == 'y')
4826                          && !isALNUM(t[1])) ||
4827                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4828                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4829                                     "!=~ should be !~");
4830                 }
4831                 Eop(OP_NE);
4832             }
4833             if (tmp == '~')
4834                 PMop(OP_NOT);
4835         }
4836         s--;
4837         OPERATOR('!');
4838     case '<':
4839         if (PL_expect != XOPERATOR) {
4840             if (s[1] != '<' && !strchr(s,'>'))
4841                 check_uni();
4842             if (s[1] == '<')
4843                 s = scan_heredoc(s);
4844             else
4845                 s = scan_inputsymbol(s);
4846             TERM(sublex_start());
4847         }
4848         s++;
4849         {
4850             char tmp = *s++;
4851             if (tmp == '<')
4852                 SHop(OP_LEFT_SHIFT);
4853             if (tmp == '=') {
4854                 tmp = *s++;
4855                 if (tmp == '>')
4856                     Eop(OP_NCMP);
4857                 s--;
4858                 Rop(OP_LE);
4859             }
4860         }
4861         s--;
4862         Rop(OP_LT);
4863     case '>':
4864         s++;
4865         {
4866             const char tmp = *s++;
4867             if (tmp == '>')
4868                 SHop(OP_RIGHT_SHIFT);
4869             else if (tmp == '=')
4870                 Rop(OP_GE);
4871         }
4872         s--;
4873         Rop(OP_GT);
4874
4875     case '$':
4876         CLINE;
4877
4878         if (PL_expect == XOPERATOR) {
4879             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4880                 PL_expect = XTERM;
4881                 deprecate_old(commaless_variable_list);
4882                 return REPORT(','); /* grandfather non-comma-format format */
4883             }
4884         }
4885
4886         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4887             PL_tokenbuf[0] = '@';
4888             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4889                            sizeof PL_tokenbuf - 1, FALSE);
4890             if (PL_expect == XOPERATOR)
4891                 no_op("Array length", s);
4892             if (!PL_tokenbuf[1])
4893                 PREREF(DOLSHARP);
4894             PL_expect = XOPERATOR;
4895             PL_pending_ident = '#';
4896             TOKEN(DOLSHARP);
4897         }
4898
4899         PL_tokenbuf[0] = '$';
4900         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4901                        sizeof PL_tokenbuf - 1, FALSE);
4902         if (PL_expect == XOPERATOR)
4903             no_op("Scalar", s);
4904         if (!PL_tokenbuf[1]) {
4905             if (s == PL_bufend)
4906                 yyerror("Final $ should be \\$ or $name");
4907             PREREF('$');
4908         }
4909
4910         /* This kludge not intended to be bulletproof. */
4911         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4912             pl_yylval.opval = newSVOP(OP_CONST, 0,
4913                                    newSViv(CopARYBASE_get(&PL_compiling)));
4914             pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4915             TERM(THING);
4916         }
4917
4918         d = s;
4919         {
4920             const char tmp = *s;
4921             if (PL_lex_state == LEX_NORMAL)
4922                 s = SKIPSPACE1(s);
4923
4924             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4925                 && intuit_more(s)) {
4926                 if (*s == '[') {
4927                     PL_tokenbuf[0] = '@';
4928                     if (ckWARN(WARN_SYNTAX)) {
4929                         char *t = s+1;
4930
4931                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4932                             t++;
4933                         if (*t++ == ',') {
4934                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4935                             while (t < PL_bufend && *t != ']')
4936                                 t++;
4937                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4938                                         "Multidimensional syntax %.*s not supported",
4939                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4940                         }
4941                     }
4942                 }
4943                 else if (*s == '{') {
4944                     char *t;
4945                     PL_tokenbuf[0] = '%';
4946                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4947                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4948                         {
4949                             char tmpbuf[sizeof PL_tokenbuf];
4950                             do {
4951                                 t++;
4952                             } while (isSPACE(*t));
4953                             if (isIDFIRST_lazy_if(t,UTF)) {
4954                                 STRLEN len;
4955                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4956                                               &len);
4957                                 while (isSPACE(*t))
4958                                     t++;
4959                                 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4960                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4961                                                 "You need to quote \"%s\"",
4962                                                 tmpbuf);
4963                             }
4964                         }
4965                 }
4966             }
4967
4968             PL_expect = XOPERATOR;
4969             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4970                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4971                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4972                     PL_expect = XOPERATOR;
4973                 else if (strchr("$@\"'`q", *s))
4974                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4975                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4976                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4977                 else if (isIDFIRST_lazy_if(s,UTF)) {
4978                     char tmpbuf[sizeof PL_tokenbuf];
4979                     int t2;
4980                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4981                     if ((t2 = keyword(tmpbuf, len, 0))) {
4982                         /* binary operators exclude handle interpretations */
4983                         switch (t2) {
4984                         case -KEY_x:
4985                         case -KEY_eq:
4986                         case -KEY_ne:
4987                         case -KEY_gt:
4988                         case -KEY_lt:
4989                         case -KEY_ge:
4990                         case -KEY_le:
4991                         case -KEY_cmp:
4992                             break;
4993                         default:
4994                             PL_expect = XTERM;  /* e.g. print $fh length() */
4995                             break;
4996                         }
4997                     }
4998                     else {
4999                         PL_expect = XTERM;      /* e.g. print $fh subr() */
5000                     }
5001                 }
5002                 else if (isDIGIT(*s))
5003                     PL_expect = XTERM;          /* e.g. print $fh 3 */
5004                 else if (*s == '.' && isDIGIT(s[1]))
5005                     PL_expect = XTERM;          /* e.g. print $fh .3 */
5006                 else if ((*s == '?' || *s == '-' || *s == '+')
5007                          && !isSPACE(s[1]) && s[1] != '=')
5008                     PL_expect = XTERM;          /* e.g. print $fh -1 */
5009                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5010                          && s[1] != '/')
5011                     PL_expect = XTERM;          /* e.g. print $fh /.../
5012                                                    XXX except DORDOR operator
5013                                                 */
5014                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5015                          && s[2] != '=')
5016                     PL_expect = XTERM;          /* print $fh <<"EOF" */
5017             }
5018         }
5019         PL_pending_ident = '$';
5020         TOKEN('$');
5021
5022     case '@':
5023         if (PL_expect == XOPERATOR)
5024             no_op("Array", s);
5025         PL_tokenbuf[0] = '@';
5026         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5027         if (!PL_tokenbuf[1]) {
5028             PREREF('@');
5029         }
5030         if (PL_lex_state == LEX_NORMAL)
5031             s = SKIPSPACE1(s);
5032         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5033             if (*s == '{')
5034                 PL_tokenbuf[0] = '%';
5035
5036             /* Warn about @ where they meant $. */
5037             if (*s == '[' || *s == '{') {
5038                 if (ckWARN(WARN_SYNTAX)) {
5039                     const char *t = s + 1;
5040                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5041                         t++;
5042                     if (*t == '}' || *t == ']') {
5043                         t++;
5044                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5045                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5046                             "Scalar value %.*s better written as $%.*s",
5047                             (int)(t-PL_bufptr), PL_bufptr,
5048                             (int)(t-PL_bufptr-1), PL_bufptr+1);
5049                     }
5050                 }
5051             }
5052         }
5053         PL_pending_ident = '@';
5054         TERM('@');
5055
5056      case '/':                  /* may be division, defined-or, or pattern */
5057         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5058             s += 2;
5059             AOPERATOR(DORDOR);
5060         }
5061      case '?':                  /* may either be conditional or pattern */
5062         if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
5063             s += 3;
5064             LOP(OP_WARN,XTERM);
5065         }
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  */