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_foreach:
4341                     case KEY_unless:
4342                     case KEY_if:
4343                     case KEY_while:
4344                     case KEY_until:
4345                         goto got_attrs;
4346                     default:
4347                         break;
4348                     }
4349                 }
4350                 sv = newSVpvn(s, len);
4351                 if (*d == '(') {
4352                     d = scan_str(d,TRUE,TRUE);
4353                     if (!d) {
4354                         /* MUST advance bufptr here to avoid bogus
4355                            "at end of line" context messages from yyerror().
4356                          */
4357                         PL_bufptr = s + len;
4358                         yyerror("Unterminated attribute parameter in attribute list");
4359                         if (attrs)
4360                             op_free(attrs);
4361                         sv_free(sv);
4362                         return REPORT(0);       /* EOF indicator */
4363                     }
4364                 }
4365                 if (PL_lex_stuff) {
4366                     sv_catsv(sv, PL_lex_stuff);
4367                     attrs = append_elem(OP_LIST, attrs,
4368                                         newSVOP(OP_CONST, 0, sv));
4369                     SvREFCNT_dec(PL_lex_stuff);
4370                     PL_lex_stuff = NULL;
4371                 }
4372                 else {
4373                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4374                         sv_free(sv);
4375                         if (PL_in_my == KEY_our) {
4376 #ifdef USE_ITHREADS
4377                             GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
4378 #else
4379                             /* skip to avoid loading attributes.pm */
4380 #endif
4381                             deprecate(":unique");
4382                         }
4383                         else
4384                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4385                     }
4386
4387                     /* NOTE: any CV attrs applied here need to be part of
4388                        the CVf_BUILTIN_ATTRS define in cv.h! */
4389                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4390                         sv_free(sv);
4391                         CvLVALUE_on(PL_compcv);
4392                     }
4393                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4394                         sv_free(sv);
4395                         CvLOCKED_on(PL_compcv);
4396                     }
4397                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4398                         sv_free(sv);
4399                         CvMETHOD_on(PL_compcv);
4400                     }
4401                     /* After we've set the flags, it could be argued that
4402                        we don't need to do the attributes.pm-based setting
4403                        process, and shouldn't bother appending recognized
4404                        flags.  To experiment with that, uncomment the
4405                        following "else".  (Note that's already been
4406                        uncommented.  That keeps the above-applied built-in
4407                        attributes from being intercepted (and possibly
4408                        rejected) by a package's attribute routines, but is
4409                        justified by the performance win for the common case
4410                        of applying only built-in attributes.) */
4411                     else
4412                         attrs = append_elem(OP_LIST, attrs,
4413                                             newSVOP(OP_CONST, 0,
4414                                                     sv));
4415                 }
4416                 s = PEEKSPACE(d);
4417                 if (*s == ':' && s[1] != ':')
4418                     s = PEEKSPACE(s+1);
4419                 else if (s == d)
4420                     break;      /* require real whitespace or :'s */
4421                 /* XXX losing whitespace on sequential attributes here */
4422             }
4423             {
4424                 const char tmp
4425                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4426                 if (*s != ';' && *s != '}' && *s != tmp
4427                     && (tmp != '=' || *s != ')')) {
4428                     const char q = ((*s == '\'') ? '"' : '\'');
4429                     /* If here for an expression, and parsed no attrs, back
4430                        off. */
4431                     if (tmp == '=' && !attrs) {
4432                         s = PL_bufptr;
4433                         break;
4434                     }
4435                     /* MUST advance bufptr here to avoid bogus "at end of line"
4436                        context messages from yyerror().
4437                     */
4438                     PL_bufptr = s;
4439                     yyerror( (const char *)
4440                              (*s
4441                               ? Perl_form(aTHX_ "Invalid separator character "
4442                                           "%c%c%c in attribute list", q, *s, q)
4443                               : "Unterminated attribute list" ) );
4444                     if (attrs)
4445                         op_free(attrs);
4446                     OPERATOR(':');
4447                 }
4448             }
4449         got_attrs:
4450             if (attrs) {
4451                 start_force(PL_curforce);
4452                 NEXTVAL_NEXTTOKE.opval = attrs;
4453                 CURMAD('_', PL_nextwhite);
4454                 force_next(THING);
4455             }
4456 #ifdef PERL_MAD
4457             if (PL_madskills) {
4458                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4459                                      (s - SvPVX(PL_linestr)) - stuffstart);
4460             }
4461 #endif
4462             TOKEN(COLONATTR);
4463         }
4464         OPERATOR(':');
4465     case '(':
4466         s++;
4467         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4468             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4469         else
4470             PL_expect = XTERM;
4471         s = SKIPSPACE1(s);
4472         TOKEN('(');
4473     case ';':
4474         CLINE;
4475         {
4476             const char tmp = *s++;
4477             OPERATOR(tmp);
4478         }
4479     case ')':
4480         {
4481             const char tmp = *s++;
4482             s = SKIPSPACE1(s);
4483             if (*s == '{')
4484                 PREBLOCK(tmp);
4485             TERM(tmp);
4486         }
4487     case ']':
4488         s++;
4489         if (PL_lex_brackets <= 0)
4490             yyerror("Unmatched right square bracket");
4491         else
4492             --PL_lex_brackets;
4493         if (PL_lex_state == LEX_INTERPNORMAL) {
4494             if (PL_lex_brackets == 0) {
4495                 if (*s == '-' && s[1] == '>')
4496                     PL_lex_state = LEX_INTERPENDMAYBE;
4497                 else if (*s != '[' && *s != '{')
4498                     PL_lex_state = LEX_INTERPEND;
4499             }
4500         }
4501         TERM(']');
4502     case '{':
4503       leftbracket:
4504         s++;
4505         if (PL_lex_brackets > 100) {
4506             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4507         }
4508         switch (PL_expect) {
4509         case XTERM:
4510             if (PL_lex_formbrack) {
4511                 s--;
4512                 PRETERMBLOCK(DO);
4513             }
4514             if (PL_oldoldbufptr == PL_last_lop)
4515                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4516             else
4517                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4518             OPERATOR(HASHBRACK);
4519         case XOPERATOR:
4520             while (s < PL_bufend && SPACE_OR_TAB(*s))
4521                 s++;
4522             d = s;
4523             PL_tokenbuf[0] = '\0';
4524             if (d < PL_bufend && *d == '-') {
4525                 PL_tokenbuf[0] = '-';
4526                 d++;
4527                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4528                     d++;
4529             }
4530             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4531                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4532                               FALSE, &len);
4533                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4534                     d++;
4535                 if (*d == '}') {
4536                     const char minus = (PL_tokenbuf[0] == '-');
4537                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4538                     if (minus)
4539                         force_next('-');
4540                 }
4541             }
4542             /* FALL THROUGH */
4543         case XATTRBLOCK:
4544         case XBLOCK:
4545             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4546             PL_expect = XSTATE;
4547             break;
4548         case XATTRTERM:
4549         case XTERMBLOCK:
4550             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4551             PL_expect = XSTATE;
4552             break;
4553         default: {
4554                 const char *t;
4555                 if (PL_oldoldbufptr == PL_last_lop)
4556                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4557                 else
4558                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4559                 s = SKIPSPACE1(s);
4560                 if (*s == '}') {
4561                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4562                         PL_expect = XTERM;
4563                         /* This hack is to get the ${} in the message. */
4564                         PL_bufptr = s+1;
4565                         yyerror("syntax error");
4566                         break;
4567                     }
4568                     OPERATOR(HASHBRACK);
4569                 }
4570                 /* This hack serves to disambiguate a pair of curlies
4571                  * as being a block or an anon hash.  Normally, expectation
4572                  * determines that, but in cases where we're not in a
4573                  * position to expect anything in particular (like inside
4574                  * eval"") we have to resolve the ambiguity.  This code
4575                  * covers the case where the first term in the curlies is a
4576                  * quoted string.  Most other cases need to be explicitly
4577                  * disambiguated by prepending a "+" before the opening
4578                  * curly in order to force resolution as an anon hash.
4579                  *
4580                  * XXX should probably propagate the outer expectation
4581                  * into eval"" to rely less on this hack, but that could
4582                  * potentially break current behavior of eval"".
4583                  * GSAR 97-07-21
4584                  */
4585                 t = s;
4586                 if (*s == '\'' || *s == '"' || *s == '`') {
4587                     /* common case: get past first string, handling escapes */
4588                     for (t++; t < PL_bufend && *t != *s;)
4589                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4590                             t++;
4591                     t++;
4592                 }
4593                 else if (*s == 'q') {
4594                     if (++t < PL_bufend
4595                         && (!isALNUM(*t)
4596                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4597                                 && !isALNUM(*t))))
4598                     {
4599                         /* skip q//-like construct */
4600                         const char *tmps;
4601                         char open, close, term;
4602                         I32 brackets = 1;
4603
4604                         while (t < PL_bufend && isSPACE(*t))
4605                             t++;
4606                         /* check for q => */
4607                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4608                             OPERATOR(HASHBRACK);
4609                         }
4610                         term = *t;
4611                         open = term;
4612                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4613                             term = tmps[5];
4614                         close = term;
4615                         if (open == close)
4616                             for (t++; t < PL_bufend; t++) {
4617                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4618                                     t++;
4619                                 else if (*t == open)
4620                                     break;
4621                             }
4622                         else {
4623                             for (t++; t < PL_bufend; t++) {
4624                                 if (*t == '\\' && t+1 < PL_bufend)
4625                                     t++;
4626                                 else if (*t == close && --brackets <= 0)
4627                                     break;
4628                                 else if (*t == open)
4629                                     brackets++;
4630                             }
4631                         }
4632                         t++;
4633                     }
4634                     else
4635                         /* skip plain q word */
4636                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4637                              t += UTF8SKIP(t);
4638                 }
4639                 else if (isALNUM_lazy_if(t,UTF)) {
4640                     t += UTF8SKIP(t);
4641                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4642                          t += UTF8SKIP(t);
4643                 }
4644                 while (t < PL_bufend && isSPACE(*t))
4645                     t++;
4646                 /* if comma follows first term, call it an anon hash */
4647                 /* XXX it could be a comma expression with loop modifiers */
4648                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4649                                    || (*t == '=' && t[1] == '>')))
4650                     OPERATOR(HASHBRACK);
4651                 if (PL_expect == XREF)
4652                     PL_expect = XTERM;
4653                 else {
4654                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4655                     PL_expect = XSTATE;
4656                 }
4657             }
4658             break;
4659         }
4660         pl_yylval.ival = CopLINE(PL_curcop);
4661         if (isSPACE(*s) || *s == '#')
4662             PL_copline = NOLINE;   /* invalidate current command line number */
4663         TOKEN('{');
4664     case '}':
4665       rightbracket:
4666         s++;
4667         if (PL_lex_brackets <= 0)
4668             yyerror("Unmatched right curly bracket");
4669         else
4670             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4671         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4672             PL_lex_formbrack = 0;
4673         if (PL_lex_state == LEX_INTERPNORMAL) {
4674             if (PL_lex_brackets == 0) {
4675                 if (PL_expect & XFAKEBRACK) {
4676                     PL_expect &= XENUMMASK;
4677                     PL_lex_state = LEX_INTERPEND;
4678                     PL_bufptr = s;
4679 #if 0
4680                     if (PL_madskills) {
4681                         if (!PL_thiswhite)
4682                             PL_thiswhite = newSVpvs("");
4683                         sv_catpvs(PL_thiswhite,"}");
4684                     }
4685 #endif
4686                     return yylex();     /* ignore fake brackets */
4687                 }
4688                 if (*s == '-' && s[1] == '>')
4689                     PL_lex_state = LEX_INTERPENDMAYBE;
4690                 else if (*s != '[' && *s != '{')
4691                     PL_lex_state = LEX_INTERPEND;
4692             }
4693         }
4694         if (PL_expect & XFAKEBRACK) {
4695             PL_expect &= XENUMMASK;
4696             PL_bufptr = s;
4697             return yylex();             /* ignore fake brackets */
4698         }
4699         start_force(PL_curforce);
4700         if (PL_madskills) {
4701             curmad('X', newSVpvn(s-1,1));
4702             CURMAD('_', PL_thiswhite);
4703         }
4704         force_next('}');
4705 #ifdef PERL_MAD
4706         if (!PL_thistoken)
4707             PL_thistoken = newSVpvs("");
4708 #endif
4709         TOKEN(';');
4710     case '&':
4711         s++;
4712         if (*s++ == '&')
4713             AOPERATOR(ANDAND);
4714         s--;
4715         if (PL_expect == XOPERATOR) {
4716             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4717                 && isIDFIRST_lazy_if(s,UTF))
4718             {
4719                 CopLINE_dec(PL_curcop);
4720                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4721                 CopLINE_inc(PL_curcop);
4722             }
4723             BAop(OP_BIT_AND);
4724         }
4725
4726         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4727         if (*PL_tokenbuf) {
4728             PL_expect = XOPERATOR;
4729             force_ident(PL_tokenbuf, '&');
4730         }
4731         else
4732             PREREF('&');
4733         pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4734         TERM('&');
4735
4736     case '|':
4737         s++;
4738         if (*s++ == '|')
4739             AOPERATOR(OROR);
4740         s--;
4741         BOop(OP_BIT_OR);
4742     case '=':
4743         s++;
4744         {
4745             const char tmp = *s++;
4746             if (tmp == '=')
4747                 Eop(OP_EQ);
4748             if (tmp == '>')
4749                 OPERATOR(',');
4750             if (tmp == '~')
4751                 PMop(OP_MATCH);
4752             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4753                 && strchr("+-*/%.^&|<",tmp))
4754                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4755                             "Reversed %c= operator",(int)tmp);
4756             s--;
4757             if (PL_expect == XSTATE && isALPHA(tmp) &&
4758                 (s == PL_linestart+1 || s[-2] == '\n') )
4759                 {
4760                     if (PL_in_eval && !PL_rsfp) {
4761                         d = PL_bufend;
4762                         while (s < d) {
4763                             if (*s++ == '\n') {
4764                                 incline(s);
4765                                 if (strnEQ(s,"=cut",4)) {
4766                                     s = strchr(s,'\n');
4767                                     if (s)
4768                                         s++;
4769                                     else
4770                                         s = d;
4771                                     incline(s);
4772                                     goto retry;
4773                                 }
4774                             }
4775                         }
4776                         goto retry;
4777                     }
4778 #ifdef PERL_MAD
4779                     if (PL_madskills) {
4780                         if (!PL_thiswhite)
4781                             PL_thiswhite = newSVpvs("");
4782                         sv_catpvn(PL_thiswhite, PL_linestart,
4783                                   PL_bufend - PL_linestart);
4784                     }
4785 #endif
4786                     s = PL_bufend;
4787                     PL_doextract = TRUE;
4788                     goto retry;
4789                 }
4790         }
4791         if (PL_lex_brackets < PL_lex_formbrack) {
4792             const char *t = s;
4793 #ifdef PERL_STRICT_CR
4794             while (SPACE_OR_TAB(*t))
4795 #else
4796             while (SPACE_OR_TAB(*t) || *t == '\r')
4797 #endif
4798                 t++;
4799             if (*t == '\n' || *t == '#') {
4800                 s--;
4801                 PL_expect = XBLOCK;
4802                 goto leftbracket;
4803             }
4804         }
4805         pl_yylval.ival = 0;
4806         OPERATOR(ASSIGNOP);
4807     case '!':
4808         if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
4809             s += 3;
4810             LOP(OP_DIE,XTERM);
4811         }
4812         s++;
4813         {
4814             const char tmp = *s++;
4815             if (tmp == '=') {
4816                 /* was this !=~ where !~ was meant?
4817                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4818
4819                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4820                     const char *t = s+1;
4821
4822                     while (t < PL_bufend && isSPACE(*t))
4823                         ++t;
4824
4825                     if (*t == '/' || *t == '?' ||
4826                         ((*t == 'm' || *t == 's' || *t == 'y')
4827                          && !isALNUM(t[1])) ||
4828                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4829                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4830                                     "!=~ should be !~");
4831                 }
4832                 Eop(OP_NE);
4833             }
4834             if (tmp == '~')
4835                 PMop(OP_NOT);
4836         }
4837         s--;
4838         OPERATOR('!');
4839     case '<':
4840         if (PL_expect != XOPERATOR) {
4841             if (s[1] != '<' && !strchr(s,'>'))
4842                 check_uni();
4843             if (s[1] == '<')
4844                 s = scan_heredoc(s);
4845             else
4846                 s = scan_inputsymbol(s);
4847             TERM(sublex_start());
4848         }
4849         s++;
4850         {
4851             char tmp = *s++;
4852             if (tmp == '<')
4853                 SHop(OP_LEFT_SHIFT);
4854             if (tmp == '=') {
4855                 tmp = *s++;
4856                 if (tmp == '>')
4857                     Eop(OP_NCMP);
4858                 s--;
4859                 Rop(OP_LE);
4860             }
4861         }
4862         s--;
4863         Rop(OP_LT);
4864     case '>':
4865         s++;
4866         {
4867             const char tmp = *s++;
4868             if (tmp == '>')
4869                 SHop(OP_RIGHT_SHIFT);
4870             else if (tmp == '=')
4871                 Rop(OP_GE);
4872         }
4873         s--;
4874         Rop(OP_GT);
4875
4876     case '$':
4877         CLINE;
4878
4879         if (PL_expect == XOPERATOR) {
4880             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4881                 PL_expect = XTERM;
4882                 deprecate_old(commaless_variable_list);
4883                 return REPORT(','); /* grandfather non-comma-format format */
4884             }
4885         }
4886
4887         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4888             PL_tokenbuf[0] = '@';
4889             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4890                            sizeof PL_tokenbuf - 1, FALSE);
4891             if (PL_expect == XOPERATOR)
4892                 no_op("Array length", s);
4893             if (!PL_tokenbuf[1])
4894                 PREREF(DOLSHARP);
4895             PL_expect = XOPERATOR;
4896             PL_pending_ident = '#';
4897             TOKEN(DOLSHARP);
4898         }
4899
4900         PL_tokenbuf[0] = '$';
4901         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4902                        sizeof PL_tokenbuf - 1, FALSE);
4903         if (PL_expect == XOPERATOR)
4904             no_op("Scalar", s);
4905         if (!PL_tokenbuf[1]) {
4906             if (s == PL_bufend)
4907                 yyerror("Final $ should be \\$ or $name");
4908             PREREF('$');
4909         }
4910
4911         /* This kludge not intended to be bulletproof. */
4912         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4913             pl_yylval.opval = newSVOP(OP_CONST, 0,
4914                                    newSViv(CopARYBASE_get(&PL_compiling)));
4915             pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4916             TERM(THING);
4917         }
4918
4919         d = s;
4920         {
4921             const char tmp = *s;
4922             if (PL_lex_state == LEX_NORMAL)
4923                 s = SKIPSPACE1(s);
4924
4925             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4926                 && intuit_more(s)) {
4927                 if (*s == '[') {
4928                     PL_tokenbuf[0] = '@';
4929                     if (ckWARN(WARN_SYNTAX)) {
4930                         char *t = s+1;
4931
4932                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4933                             t++;
4934                         if (*t++ == ',') {
4935                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4936                             while (t < PL_bufend && *t != ']')
4937                                 t++;
4938                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4939                                         "Multidimensional syntax %.*s not supported",
4940                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4941                         }
4942                     }
4943                 }
4944                 else if (*s == '{') {
4945                     char *t;
4946                     PL_tokenbuf[0] = '%';
4947                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4948                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4949                         {
4950                             char tmpbuf[sizeof PL_tokenbuf];
4951                             do {
4952                                 t++;
4953                             } while (isSPACE(*t));
4954                             if (isIDFIRST_lazy_if(t,UTF)) {
4955                                 STRLEN len;
4956                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4957                                               &len);
4958                                 while (isSPACE(*t))
4959                                     t++;
4960                                 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4961                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4962                                                 "You need to quote \"%s\"",
4963                                                 tmpbuf);
4964                             }
4965                         }
4966                 }
4967             }
4968
4969             PL_expect = XOPERATOR;
4970             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4971                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4972                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4973                     PL_expect = XOPERATOR;
4974                 else if (strchr("$@\"'`q", *s))
4975                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4976                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4977                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4978                 else if (isIDFIRST_lazy_if(s,UTF)) {
4979                     char tmpbuf[sizeof PL_tokenbuf];
4980                     int t2;
4981                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4982                     if ((t2 = keyword(tmpbuf, len, 0))) {
4983                         /* binary operators exclude handle interpretations */
4984                         switch (t2) {
4985                         case -KEY_x:
4986                         case -KEY_eq:
4987                         case -KEY_ne:
4988                         case -KEY_gt:
4989                         case -KEY_lt:
4990                         case -KEY_ge:
4991                         case -KEY_le:
4992                         case -KEY_cmp:
4993                             break;
4994                         default:
4995                             PL_expect = XTERM;  /* e.g. print $fh length() */
4996                             break;
4997                         }
4998                     }
4999                     else {
5000                         PL_expect = XTERM;      /* e.g. print $fh subr() */
5001                     }
5002                 }
5003                 else if (isDIGIT(*s))
5004                     PL_expect = XTERM;          /* e.g. print $fh 3 */
5005                 else if (*s == '.' && isDIGIT(s[1]))
5006                     PL_expect = XTERM;          /* e.g. print $fh .3 */
5007                 else if ((*s == '?' || *s == '-' || *s == '+')
5008                          && !isSPACE(s[1]) && s[1] != '=')
5009                     PL_expect = XTERM;          /* e.g. print $fh -1 */
5010                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5011                          && s[1] != '/')
5012                     PL_expect = XTERM;          /* e.g. print $fh /.../
5013                                                    XXX except DORDOR operator
5014                                                 */
5015                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5016                          && s[2] != '=')
5017                     PL_expect = XTERM;          /* print $fh <<"EOF" */
5018             }
5019         }
5020         PL_pending_ident = '$';
5021         TOKEN('$');
5022
5023     case '@':
5024         if (PL_expect == XOPERATOR)
5025             no_op("Array", s);
5026         PL_tokenbuf[0] = '@';
5027         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5028         if (!PL_tokenbuf[1]) {
5029             PREREF('@');
5030         }
5031         if (PL_lex_state == LEX_NORMAL)
5032             s = SKIPSPACE1(s);
5033         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5034             if (*s == '{')
5035                 PL_tokenbuf[0] = '%';
5036
5037             /* Warn about @ where they meant $. */
5038             if (*s == '[' || *s == '{') {
5039                 if (ckWARN(WARN_SYNTAX)) {
5040                     const char *t = s + 1;
5041                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5042                         t++;
5043                     if (*t == '}' || *t == ']') {
5044                         t++;
5045                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5046                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5047                             "Scalar value %.*s better written as $%.*s",
5048                             (int)(t-PL_bufptr), PL_bufptr,
5049                             (int)(t-PL_bufptr-1), PL_bufptr+1);
5050                     }
5051                 }
5052             }
5053         }
5054         PL_pending_ident = '@';
5055         TERM('@');
5056
5057      case '/':                  /* may be division, defined-or, or pattern */
5058         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5059             s += 2;
5060             AOPERATOR(DORDOR);
5061         }
5062      case '?':                  /* may either be conditional or pattern */
5063         if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
5064             s += 3;
5065             LOP(OP_WARN,XTERM);
5066         }
5067         if (PL_expect == XOPERATOR) {
5068              char tmp = *s++;
5069              if(tmp == '?') {
5070                 OPERATOR('?');
5071              }
5072              else {
5073                  tmp = *s++;
5074                  if(tmp == '/') {
5075                      /* A // operator. */
5076                     AOPERATOR(DORDOR);
5077                  }
5078                  else {
5079                      s--;
5080                      Mop(OP_DIVIDE);
5081                  }
5082              }
5083          }
5084          else {
5085              /* Disable warning on "study /blah/" */
5086              if (PL_oldoldbufptr == PL_last_uni
5087               && (*PL_last_uni != 's' || s - PL_last_uni < 5
5088                   || memNE(PL_last_uni, "study", 5)
5089                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
5090               ))
5091                  check_uni();
5092              s = scan_pat(s,OP_MATCH);
5093              TERM(sublex_start());
5094          }
5095
5096     case '.':
5097         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5098 #ifdef PERL_STRICT_CR
5099             && s[1] == '\n'
5100 #else
5101             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5102 #endif
5103             && (s == PL_linestart || s[-1] == '\n') )
5104         {
5105             PL_lex_formbrack = 0;
5106             PL_expect = XSTATE;
5107             goto rightbracket;
5108         }
5109         if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5110             s += 3;
5111             OPERATOR(YADAYADA);
5112         }
5113         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5114             char tmp = *s++;
5115             if (*s == tmp) {
5116                 s++;
5117                 if (*s == tmp) {
5118                     s++;
5119                     pl_yylval.ival = OPf_SPECIAL;
5120                 }
5121                 else
5122                     pl_yylval.ival = 0;
5123                 OPERATOR(DOTDOT);
5124             }
5125             if (PL_expect != XOPERATOR)
5126                 check_uni();
5127             Aop(OP_CONCAT);
5128         }
5129         /* FALL THROUGH */
5130     case '0': case '1': case '2': case '3': case '4':
5131     case '5': case '6': case '7': case '8': case '9':
5132         s = scan_num(s, &pl_yylval);
5133         DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5134         if (PL_expect == XOPERATOR)
5135             no_op("Number",s);
5136         TERM(THING);
5137
5138     case '\'':
5139         s = scan_str(s,!!PL_madskills,FALSE);
5140         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5141         if (PL_expect == XOPERATOR) {
5142             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5143                 PL_expect = XTERM;
5144                 deprecate_old(commaless_variable_list);
5145                 return REPORT(','); /* grandfather non-comma-format format */
5146             }
5147             else
5148                 no_op("String",s);
5149         }
5150         if (!s)
5151             missingterm(NULL);
5152         pl_yylval.ival = OP_CONST;
5153         TERM(sublex_start());
5154
5155     case '"':
5156         s = scan_str(s,!!PL_madskills,FALSE);
5157         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5158         if (PL_expect == XOPERATOR) {
5159             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5160                 PL_expect = XTERM;
5161                 deprecate_old(commaless_variable_list);
5162                 return REPORT(','); /* grandfather non-comma-format format */
5163             }
5164             else
5165                 no_op("String",s);
5166         }
5167         if (!s)
5168             missingterm(NULL);
5169         pl_yylval.ival = OP_CONST;
5170         /* FIXME. I think that this can be const if char *d is replaced by
5171            more localised variables.  */
5172         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5173             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5174                 pl_yylval.ival = OP_STRINGIFY;
5175                 break;
5176             }
5177         }
5178         TERM(sublex_start());
5179
5180     case '`':
5181         s = scan_str(s,!!PL_madskills,FALSE);
5182         DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5183         if (PL_expect == XOPERATOR)
5184             no_op("Backticks",s);
5185         if (!s)
5186             missingterm(NULL);
5187         readpipe_override();
5188         TERM(sublex_start());
5189
5190     case '\\':
5191         s++;
5192         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5193             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5194                         *s, *s);
5195         if (PL_expect == XOPERATOR)
5196             no_op("Backslash",s);
5197         OPERATOR(REFGEN);
5198
5199     case 'v':
5200         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5201             char *start = s + 2;
5202             while (isDIGIT(*start) || *start == '_')
5203                 start++;
5204             if (*start == '.' && isDIGIT(start[1])) {
5205                 s = scan_num(s, &pl_yylval);
5206                 TERM(THING);
5207             }
5208             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5209             else if (!isALPHA(*start) && (PL_expect == XTERM
5210                         || PL_expect == XREF || PL_expect == XSTATE
5211                         || PL_expect == XTERMORDORDOR)) {
5212                 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5213                 if (!gv) {
5214                     s = scan_num(s, &pl_yylval);
5215                     TERM(THING);
5216                 }
5217             }
5218         }
5219         goto keylookup;
5220     case 'x':
5221         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5222             s++;
5223             Mop(OP_REPEAT);
5224         }
5225         goto keylookup;
5226
5227     case '_':
5228     case 'a': case 'A':
5229     case 'b': case 'B':
5230     case 'c': case 'C':
5231     case 'd': case 'D':
5232     case 'e': case 'E':
5233     case 'f': case 'F':
5234     case 'g': case 'G':
5235     case 'h': case 'H':
5236     case 'i': case 'I':
5237     case 'j': case 'J':
5238     case 'k': case 'K':
5239     case 'l': case 'L':
5240     case 'm': case 'M':
5241     case 'n': case 'N':
5242     case 'o': case 'O':
5243     case 'p': case 'P':
5244     case 'q': case 'Q':
5245     case 'r': case 'R':
5246     case 's': case 'S':
5247     case 't': case 'T':
5248     case 'u': case 'U':
5249               case 'V':
5250     case 'w': case 'W':
5251               case 'X':
5252     case 'y': case 'Y':
5253     case 'z': case 'Z':
5254
5255       keylookup: {
5256         I32 tmp;
5257
5258         orig_keyword = 0;
5259         gv = NULL;
5260         gvp = NULL;
5261
5262         PL_bufptr = s;
5263         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5264
5265         /* Some keywords can be followed by any delimiter, including ':' */
5266         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5267                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5268                              (PL_tokenbuf[0] == 'q' &&
5269                               strchr("qwxr", PL_tokenbuf[1])))));
5270
5271         /* x::* is just a word, unless x is "CORE" */
5272         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5273             goto just_a_word;
5274
5275         d = s;
5276         while (d < PL_bufend && isSPACE(*d))
5277                 d++;    /* no comments skipped here, or s### is misparsed */
5278
5279         /* Is this a label? */
5280         if (!tmp && PL_expect == XSTATE
5281               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5282             s = d + 1;
5283             pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5284             CLINE;
5285             TOKEN(LABEL);
5286         }
5287
5288         /* Check for keywords */
5289         tmp = keyword(PL_tokenbuf, len, 0);
5290
5291         /* Is this a word before a => operator? */
5292         if (*d == '=' && d[1] == '>') {
5293             CLINE;
5294             pl_yylval.opval
5295                 = (OP*)newSVOP(OP_CONST, 0,
5296                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5297             pl_yylval.opval->op_private = OPpCONST_BARE;
5298             TERM(WORD);
5299         }
5300
5301         if (tmp < 0) {                  /* second-class keyword? */
5302             GV *ogv = NULL;     /* override (winner) */
5303             GV *hgv = NULL;     /* hidden (loser) */
5304             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5305                 CV *cv;
5306                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5307                     (cv = GvCVu(gv)))
5308                 {
5309                     if (GvIMPORTED_CV(gv))
5310                         ogv = gv;
5311                     else if (! CvMETHOD(cv))
5312                         hgv = gv;
5313                 }
5314                 if (!ogv &&
5315                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5316                     (gv = *gvp) && isGV_with_GP(gv) &&
5317                     GvCVu(gv) && GvIMPORTED_CV(gv))
5318                 {
5319                     ogv = gv;
5320                 }
5321             }
5322             if (ogv) {
5323                 orig_keyword = tmp;
5324                 tmp = 0;                /* overridden by import or by GLOBAL */
5325             }
5326             else if (gv && !gvp
5327                      && -tmp==KEY_lock  /* XXX generalizable kludge */
5328                      && GvCVu(gv))
5329             {
5330                 tmp = 0;                /* any sub overrides "weak" keyword */
5331             }
5332             else {                      /* no override */
5333                 tmp = -tmp;
5334                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5335                     Perl_warner(aTHX_ packWARN(WARN_MISC),
5336                             "dump() better written as CORE::dump()");
5337                 }
5338                 gv = NULL;
5339                 gvp = 0;
5340                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5341                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
5342                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5343                         "Ambiguous call resolved as CORE::%s(), %s",
5344                          GvENAME(hgv), "qualify as such or use &");
5345             }
5346         }
5347
5348       reserved_word:
5349         switch (tmp) {
5350
5351         default:                        /* not a keyword */
5352             /* Trade off - by using this evil construction we can pull the
5353                variable gv into the block labelled keylookup. If not, then
5354                we have to give it function scope so that the goto from the
5355                earlier ':' case doesn't bypass the initialisation.  */
5356             if (0) {
5357             just_a_word_zero_gv:
5358                 gv = NULL;
5359                 gvp = NULL;
5360                 orig_keyword = 0;
5361             }
5362           just_a_word: {
5363                 SV *sv;
5364                 int pkgname = 0;
5365                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5366                 CV *cv;
5367 #ifdef PERL_MAD
5368                 SV *nextPL_nextwhite = 0;
5369 #endif
5370
5371
5372                 /* Get the rest if it looks like a package qualifier */
5373
5374                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5375                     STRLEN morelen;
5376                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5377                                   TRUE, &morelen);
5378                     if (!morelen)
5379                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5380                                 *s == '\'' ? "'" : "::");
5381                     len += morelen;
5382                     pkgname = 1;
5383                 }
5384
5385                 if (PL_expect == XOPERATOR) {
5386                     if (PL_bufptr == PL_linestart) {
5387                         CopLINE_dec(PL_curcop);
5388                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5389                         CopLINE_inc(PL_curcop);
5390                     }
5391                     else
5392                         no_op("Bareword",s);
5393                 }
5394
5395                 /* Look for a subroutine with this name in current package,
5396                    unless name is "Foo::", in which case Foo is a bearword
5397                    (and a package name). */
5398
5399                 if (len > 2 && !PL_madskills &&
5400                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5401                 {
5402                     if (ckWARN(WARN_BAREWORD)
5403                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5404                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5405                             "Bareword \"%s\" refers to nonexistent package",
5406                              PL_tokenbuf);
5407                     len -= 2;
5408                     PL_tokenbuf[len] = '\0';
5409                     gv = NULL;
5410                     gvp = 0;
5411                 }
5412                 else {
5413                     if (!gv) {
5414                         /* Mustn't actually add anything to a symbol table.
5415                            But also don't want to "initialise" any placeholder
5416                            constants that might already be there into full
5417                            blown PVGVs with attached PVCV.  */
5418                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5419                                                GV_NOADD_NOINIT, SVt_PVCV);
5420                     }
5421                     len = 0;
5422                 }
5423
5424                 /* if we saw a global override before, get the right name */
5425
5426                 if (gvp) {
5427                     sv = newSVpvs("CORE::GLOBAL::");
5428                     sv_catpv(sv,PL_tokenbuf);
5429                 }
5430                 else {
5431                     /* If len is 0, newSVpv does strlen(), which is correct.
5432                        If len is non-zero, then it will be the true length,
5433                        and so the scalar will be created correctly.  */
5434                     sv = newSVpv(PL_tokenbuf,len);
5435                 }
5436 #ifdef PERL_MAD
5437                 if (PL_madskills && !PL_thistoken) {
5438                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5439                     PL_thistoken = newSVpvn(start,s - start);
5440                     PL_realtokenstart = s - SvPVX(PL_linestr);
5441                 }
5442 #endif
5443
5444                 /* Presume this is going to be a bareword of some sort. */
5445
5446                 CLINE;
5447                 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5448                 pl_yylval.opval->op_private = OPpCONST_BARE;
5449                 /* UTF-8 package name? */
5450                 if (UTF && !IN_BYTES &&
5451                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5452                     SvUTF8_on(sv);
5453
5454                 /* And if "Foo::", then that's what it certainly is. */
5455
5456                 if (len)
5457                     goto safe_bareword;
5458
5459                 /* Do the explicit type check so that we don't need to force
5460                    the initialisation of the symbol table to have a real GV.
5461                    Beware - gv may not really be a PVGV, cv may not really be
5462                    a PVCV, (because of the space optimisations that gv_init
5463                    understands) But they're true if for this symbol there is
5464                    respectively a typeglob and a subroutine.
5465                 */
5466                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5467                     /* Real typeglob, so get the real subroutine: */
5468                            ? GvCVu(gv)
5469                     /* A proxy for a subroutine in this package? */
5470                            : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5471                     : NULL;
5472
5473                 /* See if it's the indirect object for a list operator. */
5474
5475                 if (PL_oldoldbufptr &&
5476                     PL_oldoldbufptr < PL_bufptr &&
5477                     (PL_oldoldbufptr == PL_last_lop
5478                      || PL_oldoldbufptr == PL_last_uni) &&
5479                     /* NO SKIPSPACE BEFORE HERE! */
5480                     (PL_expect == XREF ||
5481                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5482                 {
5483                     bool immediate_paren = *s == '(';
5484
5485                     /* (Now we can afford to cross potential line boundary.) */
5486                     s = SKIPSPACE2(s,nextPL_nextwhite);
5487 #ifdef PERL_MAD
5488                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5489 #endif
5490
5491                     /* Two barewords in a row may indicate method call. */
5492
5493                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5494                         (tmp = intuit_method(s, gv, cv)))
5495                         return REPORT(tmp);
5496
5497                     /* If not a declared subroutine, it's an indirect object. */
5498                     /* (But it's an indir obj regardless for sort.) */
5499                     /* Also, if "_" follows a filetest operator, it's a bareword */
5500
5501                     if (
5502                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5503                          ((!gv || !cv) &&
5504                         (PL_last_lop_op != OP_MAPSTART &&
5505                          PL_last_lop_op != OP_GREPSTART))))
5506                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5507                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5508                        )
5509                     {
5510                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5511                         goto bareword;
5512                     }
5513                 }
5514
5515                 PL_expect = XOPERATOR;
5516 #ifdef PERL_MAD
5517                 if (isSPACE(*s))
5518                     s = SKIPSPACE2(s,nextPL_nextwhite);
5519                 PL_nextwhite = nextPL_nextwhite;
5520 #else
5521                 s = skipspace(s);
5522 #endif
5523
5524                 /* Is this a word before a => operator? */
5525                 if (*s == '=' && s[1] == '>' && !pkgname) {
5526                     CLINE;
5527                     sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5528                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5529                       SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5530                     TERM(WORD);
5531                 }
5532
5533                 /* If followed by a paren, it's certainly a subroutine. */
5534                 if (*s == '(') {
5535                     CLINE;
5536                     if (cv) {
5537                         d = s + 1;
5538                         while (SPACE_OR_TAB(*d))
5539                             d++;
5540                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5541                             s = d + 1;
5542                             goto its_constant;
5543                         }
5544                     }
5545 #ifdef PERL_MAD
5546                     if (PL_madskills) {
5547                         PL_nextwhite = PL_thiswhite;
5548                         PL_thiswhite = 0;
5549                     }
5550                     start_force(PL_curforce);
5551 #endif
5552                     NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5553                     PL_expect = XOPERATOR;
5554 #ifdef PERL_MAD
5555                     if (PL_madskills) {
5556                         PL_nextwhite = nextPL_nextwhite;
5557                         curmad('X', PL_thistoken);
5558                         PL_thistoken = newSVpvs("");
5559                     }
5560 #endif
5561                     force_next(WORD);
5562                     pl_yylval.ival = 0;
5563                     TOKEN('&');
5564                 }
5565
5566                 /* If followed by var or block, call it a method (unless sub) */
5567
5568                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5569                     PL_last_lop = PL_oldbufptr;
5570                     PL_last_lop_op = OP_METHOD;
5571                     PREBLOCK(METHOD);
5572                 }
5573
5574                 /* If followed by a bareword, see if it looks like indir obj. */
5575
5576                 if (!orig_keyword
5577                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5578                         && (tmp = intuit_method(s, gv, cv)))
5579                     return REPORT(tmp);
5580
5581                 /* Not a method, so call it a subroutine (if defined) */
5582
5583                 if (cv) {
5584                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5585                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5586                                 "Ambiguous use of -%s resolved as -&%s()",
5587                                 PL_tokenbuf, PL_tokenbuf);
5588                     /* Check for a constant sub */
5589                     if ((sv = gv_const_sv(gv))) {
5590                   its_constant:
5591                         SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5592                         ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5593                         pl_yylval.opval->op_private = 0;
5594                         TOKEN(WORD);
5595                     }
5596
5597                     /* Resolve to GV now. */
5598                     if (SvTYPE(gv) != SVt_PVGV) {
5599                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5600                         assert (SvTYPE(gv) == SVt_PVGV);
5601                         /* cv must have been some sort of placeholder, so
5602                            now needs replacing with a real code reference.  */
5603                         cv = GvCV(gv);
5604                     }
5605
5606                     op_free(pl_yylval.opval);
5607                     pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5608                     pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5609                     PL_last_lop = PL_oldbufptr;
5610                     PL_last_lop_op = OP_ENTERSUB;
5611                     /* Is there a prototype? */
5612                     if (
5613 #ifdef PERL_MAD
5614                         cv &&
5615 #endif
5616                         SvPOK(cv))
5617                     {
5618                         STRLEN protolen;
5619                         const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5620                         if (!protolen)
5621                             TERM(FUNC0SUB);
5622                         if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5623                             OPERATOR(UNIOPSUB);
5624                         while (*proto == ';')
5625                             proto++;
5626                         if (*proto == '&' && *s == '{') {
5627                             if (PL_curstash)
5628                                 sv_setpvs(PL_subname, "__ANON__");
5629                             else
5630                                 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5631                             PREBLOCK(LSTOPSUB);
5632                         }
5633                     }
5634 #ifdef PERL_MAD
5635                     {
5636                         if (PL_madskills) {
5637                             PL_nextwhite = PL_thiswhite;
5638                             PL_thiswhite = 0;
5639                         }
5640                         start_force(PL_curforce);
5641                         NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5642                         PL_expect = XTERM;
5643                         if (PL_madskills) {
5644                             PL_nextwhite = nextPL_nextwhite;
5645                             curmad('X', PL_thistoken);
5646                             PL_thistoken = newSVpvs("");
5647                         }
5648                         force_next(WORD);
5649                         TOKEN(NOAMP);
5650                     }
5651                 }
5652
5653                 /* Guess harder when madskills require "best effort". */
5654                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5655                     int probable_sub = 0;
5656                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5657                         probable_sub = 1;
5658                     else if (isALPHA(*s)) {
5659                         char tmpbuf[1024];
5660                         STRLEN tmplen;
5661                         d = s;
5662                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5663                         if (!keyword(tmpbuf, tmplen, 0))
5664                             probable_sub = 1;
5665                         else {
5666                             while (d < PL_bufend && isSPACE(*d))
5667                                 d++;
5668                             if (*d == '=' && d[1] == '>')
5669                                 probable_sub = 1;
5670                         }
5671                     }
5672                     if (probable_sub) {
5673                         gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5674                         op_free(pl_yylval.opval);
5675                         pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5676                         pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5677                         PL_last_lop = PL_oldbufptr;
5678                         PL_last_lop_op = OP_ENTERSUB;
5679                         PL_nextwhite = PL_thiswhite;
5680                         PL_thiswhite = 0;
5681                         start_force(PL_curforce);
5682                         NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5683                         PL_expect = XTERM;
5684                         PL_nextwhite = nextPL_nextwhite;
5685                         curmad('X', PL_thistoken);
5686                         PL_thistoken = newSVpvs("");
5687                         force_next(WORD);
5688                         TOKEN(NOAMP);
5689                     }
5690 #else
5691                     NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5692                     PL_expect = XTERM;
5693                     force_next(WORD);
5694                     TOKEN(NOAMP);
5695 #endif
5696                 }
5697
5698                 /* Call it a bare word */
5699
5700                 bareword:
5701                 if (PL_hints & HINT_STRICT_SUBS)
5702                     pl_yylval.opval->op_private |= OPpCONST_STRICT;
5703                 else {
5704                     if (lastchar != '-') {
5705                         if (ckWARN(WARN_RESERVED)) {
5706                             d = PL_tokenbuf;
5707                             while (isLOWER(*d))
5708                                 d++;
5709                             if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5710                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5711                                        PL_tokenbuf);
5712                         }
5713                     }
5714                 }
5715
5716             safe_bareword:
5717                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5718                     && ckWARN_d(WARN_AMBIGUOUS)) {
5719                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5720                         "Operator or semicolon missing before %c%s",
5721                         lastchar, PL_tokenbuf);
5722                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5723                         "Ambiguous use of %c resolved as operator %c",
5724                         lastchar, lastchar);
5725                 }
5726                 TOKEN(WORD);
5727             }
5728
5729         case KEY___FILE__:
5730             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5731                                         newSVpv(CopFILE(PL_curcop),0));
5732             TERM(THING);
5733
5734         case KEY___LINE__:
5735             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5736                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5737             TERM(THING);
5738
5739         case KEY___PACKAGE__:
5740             pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5741                                         (PL_curstash
5742                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5743                                          : &PL_sv_undef));
5744             TERM(THING);
5745
5746         case KEY___DATA__:
5747         case KEY___END__: {
5748             GV *gv;
5749             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5750                 const char *pname = "main";
5751                 if (PL_tokenbuf[2] == 'D')
5752                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5753                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5754                                 SVt_PVIO);
5755                 GvMULTI_on(gv);
5756                 if (!GvIO(gv))
5757                     GvIOp(gv) = newIO();
5758                 IoIFP(GvIOp(gv)) = PL_rsfp;
5759 #if defined(HAS_FCNTL) && defined(F_SETFD)
5760                 {
5761                     const int fd = PerlIO_fileno(PL_rsfp);
5762                     fcntl(fd,F_SETFD,fd >= 3);
5763                 }
5764 #endif
5765                 /* Mark this internal pseudo-handle as clean */
5766                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5767                 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5768                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5769                 else
5770                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5771 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5772                 /* if the script was opened in binmode, we need to revert
5773                  * it to text mode for compatibility; but only iff it has CRs
5774                  * XXX this is a questionable hack at best. */
5775                 if (PL_bufend-PL_bufptr > 2
5776                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5777                 {
5778                     Off_t loc = 0;
5779                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5780                         loc = PerlIO_tell(PL_rsfp);
5781                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5782                     }
5783 #ifdef NETWARE
5784                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5785 #else
5786                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5787 #endif  /* NETWARE */
5788 #ifdef PERLIO_IS_STDIO /* really? */
5789 #  if defined(__BORLANDC__)
5790                         /* XXX see note in do_binmode() */
5791                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5792 #  endif
5793 #endif
5794                         if (loc > 0)
5795                             PerlIO_seek(PL_rsfp, loc, 0);
5796                     }
5797                 }
5798 #endif
5799 #ifdef PERLIO_LAYERS
5800                 if (!IN_BYTES) {
5801                     if (UTF)
5802                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5803                     else if (PL_encoding) {
5804                         SV *name;
5805                         dSP;
5806                         ENTER;
5807                         SAVETMPS;
5808                         PUSHMARK(sp);
5809                         EXTEND(SP, 1);
5810                         XPUSHs(PL_encoding);
5811                         PUTBACK;
5812                         call_method("name", G_SCALAR);
5813                         SPAGAIN;
5814                         name = POPs;
5815                         PUTBACK;
5816                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5817                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5818                                                       SVfARG(name)));
5819                         FREETMPS;
5820                         LEAVE;
5821                     }
5822                 }
5823 #endif
5824 #ifdef PERL_MAD
5825                 if (PL_madskills) {
5826                     if (PL_realtokenstart >= 0) {
5827                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5828                         if (!PL_endwhite)
5829                             PL_endwhite = newSVpvs("");
5830                         sv_catsv(PL_endwhite, PL_thiswhite);
5831                         PL_thiswhite = 0;
5832                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5833                         PL_realtokenstart = -1;
5834                     }
5835                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5836                                  SvCUR(PL_endwhite))) != NULL) ;
5837                 }
5838 #endif
5839                 PL_rsfp = NULL;
5840             }
5841             goto fake_eof;
5842         }
5843
5844         case KEY_AUTOLOAD:
5845         case KEY_DESTROY:
5846         case KEY_BEGIN:
5847         case KEY_UNITCHECK:
5848         case KEY_CHECK:
5849         case KEY_INIT:
5850         case KEY_END:
5851             if (PL_expect == XSTATE) {
5852                 s = PL_bufptr;
5853                 goto really_sub;
5854             }
5855             goto just_a_word;
5856
5857         case KEY_CORE:
5858             if (*s == ':' && s[1] == ':') {
5859                 s += 2;
5860                 d = s;
5861                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5862                 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5863                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5864                 if (tmp < 0)
5865                     tmp = -tmp;
5866                 else if (tmp == KEY_require || tmp == KEY_do)
5867                     /* that's a way to remember we saw "CORE::" */
5868                     orig_keyword = tmp;
5869                 goto reserved_word;
5870             }
5871             goto just_a_word;
5872
5873         case KEY_abs:
5874             UNI(OP_ABS);
5875
5876         case KEY_alarm:
5877             UNI(OP_ALARM);
5878
5879         case KEY_accept:
5880             LOP(OP_ACCEPT,XTERM);
5881
5882         case KEY_and:
5883             OPERATOR(ANDOP);
5884
5885         case KEY_atan2:
5886             LOP(OP_ATAN2,XTERM);
5887
5888         case KEY_bind:
5889             LOP(OP_BIND,XTERM);
5890
5891         case KEY_binmode:
5892             LOP(OP_BINMODE,XTERM);
5893
5894         case KEY_bless:
5895             LOP(OP_BLESS,XTERM);
5896
5897         case KEY_break:
5898             FUN0(OP_BREAK);
5899
5900         case KEY_chop:
5901             UNI(OP_CHOP);
5902
5903         case KEY_continue:
5904             /* When 'use switch' is in effect, continue has a dual
5905                life as a control operator. */
5906             {
5907                 if (!FEATURE_IS_ENABLED("switch"))
5908                     PREBLOCK(CONTINUE);
5909                 else {
5910                     /* We have to disambiguate the two senses of
5911                       "continue". If the next token is a '{' then
5912                       treat it as the start of a continue block;
5913                       otherwise treat it as a control operator.
5914                      */
5915                     s = skipspace(s);
5916                     if (*s == '{')
5917             PREBLOCK(CONTINUE);
5918                     else
5919                         FUN0(OP_CONTINUE);
5920                 }
5921             }
5922
5923         case KEY_chdir:
5924             /* may use HOME */
5925             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5926             UNI(OP_CHDIR);
5927
5928         case KEY_close:
5929             UNI(OP_CLOSE);
5930
5931         case KEY_closedir:
5932             UNI(OP_CLOSEDIR);
5933
5934         case KEY_cmp:
5935             Eop(OP_SCMP);
5936
5937         case KEY_caller:
5938             UNI(OP_CALLER);
5939
5940         case KEY_crypt:
5941 #ifdef FCRYPT
5942             if (!PL_cryptseen) {
5943                 PL_cryptseen = TRUE;
5944                 init_des();
5945             }
5946 #endif
5947             LOP(OP_CRYPT,XTERM);
5948
5949         case KEY_chmod:
5950             LOP(OP_CHMOD,XTERM);
5951
5952         case KEY_chown:
5953             LOP(OP_CHOWN,XTERM);
5954
5955         case KEY_connect:
5956             LOP(OP_CONNECT,XTERM);
5957
5958         case KEY_chr:
5959             UNI(OP_CHR);
5960
5961         case KEY_cos:
5962             UNI(OP_COS);
5963
5964         case KEY_chroot:
5965             UNI(OP_CHROOT);
5966
5967         case KEY_default:
5968             PREBLOCK(DEFAULT);
5969
5970         case KEY_do:
5971             s = SKIPSPACE1(s);
5972             if (*s == '{')
5973                 PRETERMBLOCK(DO);
5974             if (*s != '\'')
5975                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5976             if (orig_keyword == KEY_do) {
5977                 orig_keyword = 0;
5978                 pl_yylval.ival = 1;
5979             }
5980             else
5981                 pl_yylval.ival = 0;
5982             OPERATOR(DO);
5983
5984         case KEY_die:
5985             PL_hints |= HINT_BLOCK_SCOPE;
5986             LOP(OP_DIE,XTERM);
5987
5988         case KEY_defined:
5989             UNI(OP_DEFINED);
5990
5991         case KEY_delete:
5992             UNI(OP_DELETE);
5993
5994         case KEY_dbmopen:
5995             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5996             LOP(OP_DBMOPEN,XTERM);
5997
5998         case KEY_dbmclose:
5999             UNI(OP_DBMCLOSE);
6000
6001         case KEY_dump:
6002             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6003             LOOPX(OP_DUMP);
6004
6005         case KEY_else:
6006             PREBLOCK(ELSE);
6007
6008         case KEY_elsif:
6009             pl_yylval.ival = CopLINE(PL_curcop);
6010             OPERATOR(ELSIF);
6011
6012         case KEY_eq:
6013             Eop(OP_SEQ);
6014
6015         case KEY_exists:
6016             UNI(OP_EXISTS);
6017
6018         case KEY_exit:
6019             if (PL_madskills)
6020                 UNI(OP_INT);
6021             UNI(OP_EXIT);
6022
6023         case KEY_eval:
6024             s = SKIPSPACE1(s);
6025             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6026             UNIBRACK(OP_ENTEREVAL);
6027
6028         case KEY_eof:
6029             UNI(OP_EOF);
6030
6031         case KEY_exp:
6032             UNI(OP_EXP);
6033
6034         case KEY_each:
6035             UNI(OP_EACH);
6036
6037         case KEY_exec:
6038             LOP(OP_EXEC,XREF);
6039
6040         case KEY_endhostent:
6041             FUN0(OP_EHOSTENT);
6042
6043         case KEY_endnetent:
6044             FUN0(OP_ENETENT);
6045
6046         case KEY_endservent:
6047             FUN0(OP_ESERVENT);
6048
6049         case KEY_endprotoent:
6050             FUN0(OP_EPROTOENT);
6051
6052         case KEY_endpwent:
6053             FUN0(OP_EPWENT);
6054
6055         case KEY_endgrent:
6056             FUN0(OP_EGRENT);
6057
6058         case KEY_for:
6059         case KEY_foreach:
6060             pl_yylval.ival = CopLINE(PL_curcop);
6061             s = SKIPSPACE1(s);
6062             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6063                 char *p = s;
6064 #ifdef PERL_MAD
6065                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6066 #endif
6067
6068                 if ((PL_bufend - p) >= 3 &&
6069                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6070                     p += 2;
6071                 else if ((PL_bufend - p) >= 4 &&
6072                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6073                     p += 3;
6074                 p = PEEKSPACE(p);
6075                 if (isIDFIRST_lazy_if(p,UTF)) {
6076                     p = scan_ident(p, PL_bufend,
6077                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6078                     p = PEEKSPACE(p);
6079                 }
6080                 if (*p != '$')
6081                     Perl_croak(aTHX_ "Missing $ on loop variable");
6082 #ifdef PERL_MAD
6083                 s = SvPVX(PL_linestr) + soff;
6084 #endif
6085             }
6086             OPERATOR(FOR);
6087
6088         case KEY_formline:
6089             LOP(OP_FORMLINE,XTERM);
6090
6091         case KEY_fork:
6092             FUN0(OP_FORK);
6093
6094         case KEY_fcntl:
6095             LOP(OP_FCNTL,XTERM);
6096
6097         case KEY_fileno:
6098             UNI(OP_FILENO);
6099
6100         case KEY_flock:
6101             LOP(OP_FLOCK,XTERM);
6102
6103         case KEY_gt:
6104             Rop(OP_SGT);
6105
6106         case KEY_ge:
6107             Rop(OP_SGE);
6108
6109         case KEY_grep:
6110             LOP(OP_GREPSTART, XREF);
6111
6112         case KEY_goto:
6113             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6114             LOOPX(OP_GOTO);
6115
6116         case KEY_gmtime:
6117             UNI(OP_GMTIME);
6118
6119         case KEY_getc:
6120             UNIDOR(OP_GETC);
6121
6122         case KEY_getppid:
6123             FUN0(OP_GETPPID);
6124
6125         case KEY_getpgrp:
6126             UNI(OP_GETPGRP);
6127
6128         case KEY_getpriority:
6129             LOP(OP_GETPRIORITY,XTERM);
6130
6131         case KEY_getprotobyname:
6132             UNI(OP_GPBYNAME);
6133
6134         case KEY_getprotobynumber:
6135             LOP(OP_GPBYNUMBER,XTERM);
6136
6137         case KEY_getprotoent:
6138             FUN0(OP_GPROTOENT);
6139
6140         case KEY_getpwent:
6141             FUN0(OP_GPWENT);
6142
6143         case KEY_getpwnam:
6144             UNI(OP_GPWNAM);
6145
6146         case KEY_getpwuid:
6147             UNI(OP_GPWUID);
6148
6149         case KEY_getpeername:
6150             UNI(OP_GETPEERNAME);
6151
6152         case KEY_gethostbyname:
6153             UNI(OP_GHBYNAME);
6154
6155         case KEY_gethostbyaddr:
6156             LOP(OP_GHBYADDR,XTERM);
6157
6158         case KEY_gethostent:
6159             FUN0(OP_GHOSTENT);
6160
6161         case KEY_getnetbyname:
6162             UNI(OP_GNBYNAME);
6163
6164         case KEY_getnetbyaddr:
6165             LOP(OP_GNBYADDR,XTERM);
6166
6167         case KEY_getnetent:
6168             FUN0(OP_GNETENT);
6169
6170         case KEY_getservbyname:
6171             LOP(OP_GSBYNAME,XTERM);
6172
6173         case KEY_getservbyport:
6174             LOP(OP_GSBYPORT,XTERM);
6175
6176         case KEY_getservent:
6177             FUN0(OP_GSERVENT);
6178
6179         case KEY_getsockname:
6180             UNI(OP_GETSOCKNAME);
6181
6182         case KEY_getsockopt:
6183             LOP(OP_GSOCKOPT,XTERM);
6184
6185         case KEY_getgrent:
6186             FUN0(OP_GGRENT);
6187
6188         case KEY_getgrnam:
6189             UNI(OP_GGRNAM);
6190
6191         case KEY_getgrgid:
6192             UNI(OP_GGRGID);
6193
6194         case KEY_getlogin:
6195             FUN0(OP_GETLOGIN);
6196
6197         case KEY_given:
6198             pl_yylval.ival = CopLINE(PL_curcop);
6199             OPERATOR(GIVEN);
6200
6201         case KEY_glob:
6202             LOP(OP_GLOB,XTERM);
6203
6204         case KEY_hex:
6205             UNI(OP_HEX);
6206
6207         case KEY_if:
6208             pl_yylval.ival = CopLINE(PL_curcop);
6209             OPERATOR(IF);
6210
6211         case KEY_index:
6212             LOP(OP_INDEX,XTERM);
6213
6214         case KEY_int:
6215             UNI(OP_INT);
6216
6217         case KEY_ioctl:
6218             LOP(OP_IOCTL,XTERM);
6219
6220         case KEY_join:
6221             LOP(OP_JOIN,XTERM);
6222
6223         case KEY_keys:
6224             UNI(OP_KEYS);
6225
6226         case KEY_kill:
6227             LOP(OP_KILL,XTERM);
6228
6229         case KEY_last:
6230             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6231             LOOPX(OP_LAST);
6232
6233         case KEY_lc:
6234             UNI(OP_LC);
6235
6236         case KEY_lcfirst:
6237             UNI(OP_LCFIRST);
6238
6239         case KEY_local:
6240             pl_yylval.ival = 0;
6241             OPERATOR(LOCAL);
6242
6243         case KEY_length:
6244             UNI(OP_LENGTH);
6245
6246         case KEY_lt:
6247             Rop(OP_SLT);
6248
6249         case KEY_le:
6250             Rop(OP_SLE);
6251
6252         case KEY_localtime:
6253             UNI(OP_LOCALTIME);
6254
6255         case KEY_log:
6256             UNI(OP_LOG);
6257
6258         case KEY_link:
6259             LOP(OP_LINK,XTERM);
6260
6261         case KEY_listen:
6262             LOP(OP_LISTEN,XTERM);
6263
6264         case KEY_lock:
6265             UNI(OP_LOCK);
6266
6267         case KEY_lstat:
6268             UNI(OP_LSTAT);
6269
6270         case KEY_m:
6271             s = scan_pat(s,OP_MATCH);
6272             TERM(sublex_start());
6273
6274         case KEY_map:
6275             LOP(OP_MAPSTART, XREF);
6276
6277         case KEY_mkdir:
6278             LOP(OP_MKDIR,XTERM);
6279
6280         case KEY_msgctl:
6281             LOP(OP_MSGCTL,XTERM);
6282
6283         case KEY_msgget:
6284             LOP(OP_MSGGET,XTERM);
6285
6286         case KEY_msgrcv:
6287             LOP(OP_MSGRCV,XTERM);
6288
6289         case KEY_msgsnd:
6290             LOP(OP_MSGSND,XTERM);
6291
6292         case KEY_our:
6293         case KEY_my:
6294         case KEY_state:
6295             PL_in_my = (U16)tmp;
6296             s = SKIPSPACE1(s);
6297             if (isIDFIRST_lazy_if(s,UTF)) {
6298 #ifdef PERL_MAD
6299                 char* start = s;
6300 #endif
6301                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6302                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6303                     goto really_sub;
6304                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6305                 if (!PL_in_my_stash) {
6306                     char tmpbuf[1024];
6307                     PL_bufptr = s;
6308                     my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6309                     yyerror(tmpbuf);
6310                 }
6311 #ifdef PERL_MAD
6312                 if (PL_madskills) {     /* just add type to declarator token */
6313                     sv_catsv(PL_thistoken, PL_nextwhite);
6314                     PL_nextwhite = 0;
6315                     sv_catpvn(PL_thistoken, start, s - start);
6316                 }
6317 #endif
6318             }
6319             pl_yylval.ival = 1;
6320             OPERATOR(MY);
6321
6322         case KEY_next:
6323             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6324             LOOPX(OP_NEXT);
6325
6326         case KEY_ne:
6327             Eop(OP_SNE);
6328
6329         case KEY_no:
6330             s = tokenize_use(0, s);
6331             OPERATOR(USE);
6332
6333         case KEY_not:
6334             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6335                 FUN1(OP_NOT);
6336             else
6337                 OPERATOR(NOTOP);
6338
6339         case KEY_open:
6340             s = SKIPSPACE1(s);
6341             if (isIDFIRST_lazy_if(s,UTF)) {
6342                 const char *t;
6343                 for (d = s; isALNUM_lazy_if(d,UTF);)
6344                     d++;
6345                 for (t=d; isSPACE(*t);)
6346                     t++;
6347                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6348                     /* [perl #16184] */
6349                     && !(t[0] == '=' && t[1] == '>')
6350                 ) {
6351                     int parms_len = (int)(d-s);
6352                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6353                            "Precedence problem: open %.*s should be open(%.*s)",
6354                             parms_len, s, parms_len, s);
6355                 }
6356             }
6357             LOP(OP_OPEN,XTERM);
6358
6359         case KEY_or:
6360             pl_yylval.ival = OP_OR;
6361             OPERATOR(OROP);
6362
6363         case KEY_ord:
6364             UNI(OP_ORD);
6365
6366         case KEY_oct:
6367             UNI(OP_OCT);
6368
6369         case KEY_opendir:
6370             LOP(OP_OPEN_DIR,XTERM);
6371
6372         case KEY_print:
6373             checkcomma(s,PL_tokenbuf,"filehandle");
6374             LOP(OP_PRINT,XREF);
6375
6376         case KEY_printf:
6377             checkcomma(s,PL_tokenbuf,"filehandle");
6378             LOP(OP_PRTF,XREF);
6379
6380         case KEY_prototype:
6381             UNI(OP_PROTOTYPE);
6382
6383         case KEY_push:
6384             LOP(OP_PUSH,XTERM);
6385
6386         case KEY_pop:
6387             UNIDOR(OP_POP);
6388
6389         case KEY_pos:
6390             UNIDOR(OP_POS);
6391
6392         case KEY_pack:
6393             LOP(OP_PACK,XTERM);
6394
6395         case KEY_package:
6396             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6397             OPERATOR(PACKAGE);
6398
6399         case KEY_pipe:
6400             LOP(OP_PIPE_OP,XTERM);
6401
6402         case KEY_q:
6403             s = scan_str(s,!!PL_madskills,FALSE);
6404             if (!s)
6405                 missingterm(NULL);
6406             pl_yylval.ival = OP_CONST;
6407             TERM(sublex_start());
6408
6409         case KEY_quotemeta:
6410             UNI(OP_QUOTEMETA);
6411
6412         case KEY_qw:
6413             s = scan_str(s,!!PL_madskills,FALSE);
6414             if (!s)
6415                 missingterm(NULL);
6416             PL_expect = XOPERATOR;
6417             force_next(')');
6418             if (SvCUR(PL_lex_stuff)) {
6419                 OP *words = NULL;
6420                 int warned = 0;
6421                 d = SvPV_force(PL_lex_stuff, len);
6422                 while (len) {
6423                     for (; isSPACE(*d) && len; --len, ++d)
6424                         /**/;
6425                     if (len) {
6426                         SV *sv;
6427                         const char *b = d;
6428                         if (!warned && ckWARN(WARN_QW)) {
6429                             for (; !isSPACE(*d) && len; --len, ++d) {
6430                                 if (*d == ',') {
6431                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6432                                         "Possible attempt to separate words with commas");
6433                                     ++warned;
6434                                 }
6435                                 else if (*d == '#') {
6436                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6437                                         "Possible attempt to put comments in qw() list");
6438                                     ++warned;
6439                                 }
6440                             }
6441                         }
6442                         else {
6443                             for (; !isSPACE(*d) && len; --len, ++d)
6444                                 /**/;
6445                         }
6446                         sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6447                         words = append_elem(OP_LIST, words,
6448                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6449                     }
6450                 }
6451                 if (words) {
6452                     start_force(PL_curforce);
6453                     NEXTVAL_NEXTTOKE.opval = words;
6454                     force_next(THING);
6455                 }
6456             }
6457             if (PL_lex_stuff) {
6458                 SvREFCNT_dec(PL_lex_stuff);
6459                 PL_lex_stuff = NULL;
6460             }
6461             PL_expect = XTERM;
6462             TOKEN('(');
6463
6464         case KEY_qq:
6465             s = scan_str(s,!!PL_madskills,FALSE);
6466             if (!s)
6467                 missingterm(NULL);
6468             pl_yylval.ival = OP_STRINGIFY;
6469             if (SvIVX(PL_lex_stuff) == '\'')
6470                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6471             TERM(sublex_start());
6472
6473         case KEY_qr:
6474             s = scan_pat(s,OP_QR);
6475             TERM(sublex_start());
6476
6477         case KEY_qx:
6478             s = scan_str(s,!!PL_madskills,FALSE);
6479             if (!s)
6480                 missingterm(NULL);
6481             readpipe_override();
6482             TERM(sublex_start());
6483
6484         case KEY_return:
6485             OLDLOP(OP_RETURN);
6486
6487         case KEY_require:
6488             s = SKIPSPACE1(s);
6489             if (isDIGIT(*s)) {
6490                 s = force_version(s, FALSE);
6491             }
6492             else if (*s != 'v' || !isDIGIT(s[1])
6493                     || (s = force_version(s, TRUE), *s == 'v'))
6494             {
6495                 *PL_tokenbuf = '\0';
6496                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6497                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6498                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6499                 else if (*s == '<')
6500                     yyerror("<> should be quotes");
6501             }
6502             if (orig_keyword == KEY_require) {
6503                 orig_keyword = 0;
6504                 pl_yylval.ival = 1;
6505             }
6506             else
6507                 pl_yylval.ival = 0;
6508             PL_expect = XTERM;
6509             PL_bufptr = s;
6510             PL_last_uni = PL_oldbufptr;
6511             PL_last_lop_op = OP_REQUIRE;
6512             s = skipspace(s);
6513             return REPORT( (int)REQUIRE );
6514
6515         case KEY_reset:
6516             UNI(OP_RESET);
6517
6518         case KEY_redo:
6519             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6520             LOOPX(OP_REDO);
6521
6522         case KEY_rename:
6523             LOP(OP_RENAME,XTERM);
6524
6525         case KEY_rand:
6526             UNI(OP_RAND);
6527
6528         case KEY_rmdir:
6529             UNI(OP_RMDIR);
6530
6531         case KEY_rindex:
6532             LOP(OP_RINDEX,XTERM);
6533
6534         case KEY_read:
6535             LOP(OP_READ,XTERM);
6536
6537         case KEY_readdir:
6538             UNI(OP_READDIR);
6539
6540         case KEY_readline:
6541             UNIDOR(OP_READLINE);
6542
6543         case KEY_readpipe:
6544             UNIDOR(OP_BACKTICK);
6545
6546         case KEY_rewinddir:
6547             UNI(OP_REWINDDIR);
6548
6549         case KEY_recv:
6550             LOP(OP_RECV,XTERM);
6551
6552         case KEY_reverse:
6553             LOP(OP_REVERSE,XTERM);
6554
6555         case KEY_readlink:
6556             UNIDOR(OP_READLINK);
6557
6558         case KEY_ref:
6559             UNI(OP_REF);
6560
6561         case KEY_s:
6562             s = scan_subst(s);
6563             if (pl_yylval.opval)
6564                 TERM(sublex_start());
6565             else
6566                 TOKEN(1);       /* force error */
6567
6568         case KEY_say:
6569             checkcomma(s,PL_tokenbuf,"filehandle");
6570             LOP(OP_SAY,XREF);
6571
6572         case KEY_chomp:
6573             UNI(OP_CHOMP);
6574
6575         case KEY_scalar:
6576             UNI(OP_SCALAR);
6577
6578         case KEY_select:
6579             LOP(OP_SELECT,XTERM);
6580
6581         case KEY_seek:
6582             LOP(OP_SEEK,XTERM);
6583
6584         case KEY_semctl:
6585             LOP(OP_SEMCTL,XTERM);
6586
6587         case KEY_semget:
6588             LOP(OP_SEMGET,XTERM);
6589
6590         case KEY_semop:
6591             LOP(OP_SEMOP,XTERM);
6592
6593         case KEY_send:
6594             LOP(OP_SEND,XTERM);
6595
6596         case KEY_setpgrp:
6597             LOP(OP_SETPGRP,XTERM);
6598
6599         case KEY_setpriority:
6600             LOP(OP_SETPRIORITY,XTERM);
6601
6602         case KEY_sethostent:
6603             UNI(OP_SHOSTENT);
6604
6605         case KEY_setnetent:
6606             UNI(OP_SNETENT);
6607
6608         case KEY_setservent:
6609             UNI(OP_SSERVENT);
6610
6611         case KEY_setprotoent:
6612             UNI(OP_SPROTOENT);
6613
6614         case KEY_setpwent:
6615             FUN0(OP_SPWENT);
6616
6617         case KEY_setgrent:
6618             FUN0(OP_SGRENT);
6619
6620         case KEY_seekdir:
6621             LOP(OP_SEEKDIR,XTERM);
6622
6623         case KEY_setsockopt:
6624             LOP(OP_SSOCKOPT,XTERM);
6625
6626         case KEY_shift:
6627             UNIDOR(OP_SHIFT);
6628
6629         case KEY_shmctl:
6630             LOP(OP_SHMCTL,XTERM);
6631
6632         case KEY_shmget:
6633             LOP(OP_SHMGET,XTERM);
6634
6635         case KEY_shmread:
6636             LOP(OP_SHMREAD,XTERM);
6637
6638         case KEY_shmwrite:
6639             LOP(OP_SHMWRITE,XTERM);
6640
6641         case KEY_shutdown:
6642             LOP(OP_SHUTDOWN,XTERM);
6643
6644         case KEY_sin:
6645             UNI(OP_SIN);
6646
6647         case KEY_sleep:
6648             UNI(OP_SLEEP);
6649
6650         case KEY_socket:
6651             LOP(OP_SOCKET,XTERM);
6652
6653         case KEY_socketpair:
6654             LOP(OP_SOCKPAIR,XTERM);
6655
6656         case KEY_sort:
6657             checkcomma(s,PL_tokenbuf,"subroutine name");
6658             s = SKIPSPACE1(s);
6659             if (*s == ';' || *s == ')')         /* probably a close */
6660                 Perl_croak(aTHX_ "sort is now a reserved word");
6661             PL_expect = XTERM;
6662             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6663             LOP(OP_SORT,XREF);
6664
6665         case KEY_split:
6666             LOP(OP_SPLIT,XTERM);
6667
6668         case KEY_sprintf:
6669             LOP(OP_SPRINTF,XTERM);
6670
6671         case KEY_splice:
6672             LOP(OP_SPLICE,XTERM);
6673
6674         case KEY_sqrt:
6675             UNI(OP_SQRT);
6676
6677         case KEY_srand:
6678             UNI(OP_SRAND);
6679
6680         case KEY_stat:
6681             UNI(OP_STAT);
6682
6683         case KEY_study:
6684             UNI(OP_STUDY);
6685
6686         case KEY_substr:
6687             LOP(OP_SUBSTR,XTERM);
6688
6689         case KEY_format:
6690         case KEY_sub:
6691           really_sub:
6692             {
6693                 char tmpbuf[sizeof PL_tokenbuf];
6694                 SSize_t tboffset = 0;
6695                 expectation attrful;
6696                 bool have_name, have_proto;
6697                 const int key = tmp;
6698
6699 #ifdef PERL_MAD
6700                 SV *tmpwhite = 0;
6701
6702                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6703                 SV *subtoken = newSVpvn(tstart, s - tstart);
6704                 PL_thistoken = 0;
6705
6706                 d = s;
6707                 s = SKIPSPACE2(s,tmpwhite);
6708 #else
6709                 s = skipspace(s);
6710 #endif
6711
6712                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6713                     (*s == ':' && s[1] == ':'))
6714                 {
6715 #ifdef PERL_MAD
6716                     SV *nametoke = NULL;
6717 #endif
6718
6719                     PL_expect = XBLOCK;
6720                     attrful = XATTRBLOCK;
6721                     /* remember buffer pos'n for later force_word */
6722                     tboffset = s - PL_oldbufptr;
6723                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6724 #ifdef PERL_MAD
6725                     if (PL_madskills)
6726                         nametoke = newSVpvn(s, d - s);
6727 #endif
6728                     if (memchr(tmpbuf, ':', len))
6729                         sv_setpvn(PL_subname, tmpbuf, len);
6730                     else {
6731                         sv_setsv(PL_subname,PL_curstname);
6732                         sv_catpvs(PL_subname,"::");
6733                         sv_catpvn(PL_subname,tmpbuf,len);
6734                     }
6735                     have_name = TRUE;
6736
6737 #ifdef PERL_MAD
6738
6739                     start_force(0);
6740                     CURMAD('X', nametoke);
6741                     CURMAD('_', tmpwhite);
6742                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6743                                       FALSE, TRUE, TRUE);
6744
6745                     s = SKIPSPACE2(d,tmpwhite);
6746 #else
6747                     s = skipspace(d);
6748 #endif
6749                 }
6750                 else {
6751                     if (key == KEY_my)
6752                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6753                     PL_expect = XTERMBLOCK;
6754                     attrful = XATTRTERM;
6755                     sv_setpvs(PL_subname,"?");
6756                     have_name = FALSE;
6757                 }
6758
6759                 if (key == KEY_format) {
6760                     if (*s == '=')
6761                         PL_lex_formbrack = PL_lex_brackets + 1;
6762 #ifdef PERL_MAD
6763                     PL_thistoken = subtoken;
6764                     s = d;
6765 #else
6766                     if (have_name)
6767                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6768                                           FALSE, TRUE, TRUE);
6769 #endif
6770                     OPERATOR(FORMAT);
6771                 }
6772
6773                 /* Look for a prototype */
6774                 if (*s == '(') {
6775                     char *p;
6776                     bool bad_proto = FALSE;
6777                     bool in_brackets = FALSE;
6778                     char greedy_proto = ' ';
6779                     bool proto_after_greedy_proto = FALSE;
6780                     bool must_be_last = FALSE;
6781                     bool underscore = FALSE;
6782                     bool seen_underscore = FALSE;
6783                     const bool warnsyntax = ckWARN(WARN_SYNTAX);
6784
6785                     s = scan_str(s,!!PL_madskills,FALSE);
6786                     if (!s)
6787                         Perl_croak(aTHX_ "Prototype not terminated");
6788                     /* strip spaces and check for bad characters */
6789                     d = SvPVX(PL_lex_stuff);
6790                     tmp = 0;
6791                     for (p = d; *p; ++p) {
6792                         if (!isSPACE(*p)) {
6793                             d[tmp++] = *p;
6794
6795                             if (warnsyntax) {
6796                                 if (must_be_last)
6797                                     proto_after_greedy_proto = TRUE;
6798                                 if (!strchr("$@%*;[]&\\_", *p)) {
6799                                     bad_proto = TRUE;
6800                                 }
6801                                 else {
6802                                     if ( underscore ) {
6803                                         if ( *p != ';' )
6804                                             bad_proto = TRUE;
6805                                         underscore = FALSE;
6806                                     }
6807                                     if ( *p == '[' ) {
6808                                         in_brackets = TRUE;
6809                                     }
6810                                     else if ( *p == ']' ) {
6811                                         in_brackets = FALSE;
6812                                     }
6813                                     else if ( (*p == '@' || *p == '%') &&
6814                                          ( tmp < 2 || d[tmp-2] != '\\' ) &&
6815                                          !in_brackets ) {
6816                                         must_be_last = TRUE;
6817                                         greedy_proto = *p;
6818                                     }
6819                                     else if ( *p == '_' ) {
6820                                         underscore = seen_underscore = TRUE;
6821                                     }
6822                                 }
6823                             }
6824                         }
6825                     }
6826                     d[tmp] = '\0';
6827                     if (proto_after_greedy_proto)
6828                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6829                                     "Prototype after '%c' for %"SVf" : %s",
6830                                     greedy_proto, SVfARG(PL_subname), d);
6831                     if (bad_proto)
6832                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6833                                     "Illegal character %sin prototype for %"SVf" : %s",
6834                                     seen_underscore ? "after '_' " : "",
6835                                     SVfARG(PL_subname), d);
6836                     SvCUR_set(PL_lex_stuff, tmp);
6837                     have_proto = TRUE;
6838
6839 #ifdef PERL_MAD
6840                     start_force(0);
6841                     CURMAD('q', PL_thisopen);
6842                     CURMAD('_', tmpwhite);
6843                     CURMAD('=', PL_thisstuff);
6844                     CURMAD('Q', PL_thisclose);
6845                     NEXTVAL_NEXTTOKE.opval =
6846                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6847                     PL_lex_stuff = NULL;
6848                     force_next(THING);
6849
6850                     s = SKIPSPACE2(s,tmpwhite);
6851 #else
6852                     s = skipspace(s);
6853 #endif
6854                 }
6855                 else
6856                     have_proto = FALSE;
6857
6858                 if (*s == ':' && s[1] != ':')
6859                     PL_expect = attrful;
6860                 else if (*s != '{' && key == KEY_sub) {
6861                     if (!have_name)
6862                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6863                     else if (*s != ';')
6864                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6865                 }
6866
6867 #ifdef PERL_MAD
6868                 start_force(0);
6869                 if (tmpwhite) {
6870                     if (PL_madskills)
6871                         curmad('^', newSVpvs(""));
6872                     CURMAD('_', tmpwhite);
6873                 }
6874                 force_next(0);
6875
6876                 PL_thistoken = subtoken;
6877 #else
6878                 if (have_proto) {
6879                     NEXTVAL_NEXTTOKE.opval =
6880                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6881                     PL_lex_stuff = NULL;
6882                     force_next(THING);
6883                 }
6884 #endif
6885                 if (!have_name) {
6886                     if (PL_curstash)
6887                         sv_setpvs(PL_subname, "__ANON__");
6888                     else
6889                         sv_setpvs(PL_subname, "__ANON__::__ANON__");
6890                     TOKEN(ANONSUB);
6891                 }
6892 #ifndef PERL_MAD
6893                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6894                                   FALSE, TRUE, TRUE);
6895 #endif
6896                 if (key == KEY_my)
6897                     TOKEN(MYSUB);
6898                 TOKEN(SUB);
6899             }
6900
6901         case KEY_system:
6902             LOP(OP_SYSTEM,XREF);
6903
6904         case KEY_symlink:
6905             LOP(OP_SYMLINK,XTERM);
6906
6907         case KEY_syscall:
6908             LOP(OP_SYSCALL,XTERM);
6909
6910         case KEY_sysopen:
6911             LOP(OP_SYSOPEN,XTERM);
6912
6913         case KEY_sysseek:
6914             LOP(OP_SYSSEEK,XTERM);
6915
6916         case KEY_sysread:
6917             LOP(OP_SYSREAD,XTERM);
6918
6919         case KEY_syswrite:
6920             LOP(OP_SYSWRITE,XTERM);
6921
6922         case KEY_tr:
6923             s = scan_trans(s);
6924             TERM(sublex_start());
6925
6926         case KEY_tell:
6927             UNI(OP_TELL);
6928
6929         case KEY_telldir:
6930             UNI(OP_TELLDIR);
6931
6932         case KEY_tie:
6933             LOP(OP_TIE,XTERM);
6934
6935         case KEY_tied:
6936             UNI(OP_TIED);
6937
6938         case KEY_time:
6939             FUN0(OP_TIME);
6940
6941         case KEY_times:
6942             FUN0(OP_TMS);
6943
6944         case KEY_truncate:
6945             LOP(OP_TRUNCATE,XTERM);
6946
6947         case KEY_uc:
6948             UNI(OP_UC);
6949
6950         case KEY_ucfirst:
6951             UNI(OP_UCFIRST);
6952
6953         case KEY_untie:
6954             UNI(OP_UNTIE);
6955
6956         case KEY_until:
6957             pl_yylval.ival = CopLINE(PL_curcop);
6958             OPERATOR(UNTIL);
6959
6960         case KEY_unless:
6961             pl_yylval.ival = CopLINE(PL_curcop);
6962             OPERATOR(UNLESS);
6963
6964         case KEY_unlink:
6965             LOP(OP_UNLINK,XTERM);
6966
6967         case KEY_undef:
6968             UNIDOR(OP_UNDEF);
6969
6970         case KEY_unpack:
6971             LOP(OP_UNPACK,XTERM);
6972
6973         case KEY_utime:
6974             LOP(OP_UTIME,XTERM);
6975
6976         case KEY_umask:
6977             UNIDOR(OP_UMASK);
6978
6979         case KEY_unshift:
6980             LOP(OP_UNSHIFT,XTERM);
6981
6982         case KEY_use:
6983             s = tokenize_use(1, s);
6984             OPERATOR(USE);
6985
6986         case KEY_values:
6987             UNI(OP_VALUES);
6988
6989         case KEY_vec:
6990             LOP(OP_VEC,XTERM);
6991
6992         case KEY_when:
6993             pl_yylval.ival = CopLINE(PL_curcop);
6994             OPERATOR(WHEN);
6995
6996         case KEY_while:
6997             pl_yylval.ival = CopLINE(PL_curcop);
6998             OPERATOR(WHILE);
6999
7000         case KEY_warn:
7001             PL_hints |= HINT_BLOCK_SCOPE;
7002             LOP(OP_WARN,XTERM);
7003
7004         case KEY_wait:
7005             FUN0(OP_WAIT);
7006
7007         case KEY_waitpid:
7008             LOP(OP_WAITPID,XTERM);
7009
7010         case KEY_wantarray:
7011             FUN0(OP_WANTARRAY);
7012
7013         case KEY_write:
7014 #ifdef EBCDIC
7015         {
7016             char ctl_l[2];
7017             ctl_l[0] = toCTRL('L');
7018             ctl_l[1] = '\0';
7019             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7020         }
7021 #else
7022             /* Make sure $^L is defined */
7023             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7024 #endif
7025             UNI(OP_ENTERWRITE);
7026
7027         case KEY_x:
7028             if (PL_expect == XOPERATOR)
7029                 Mop(OP_REPEAT);
7030             check_uni();
7031             goto just_a_word;
7032
7033         case KEY_xor:
7034             pl_yylval.ival = OP_XOR;
7035             OPERATOR(OROP);
7036
7037         case KEY_y:
7038             s = scan_trans(s);
7039             TERM(sublex_start());
7040         }
7041     }}
7042 }
7043 #ifdef __SC__
7044 #pragma segment Main
7045 #endif
7046
7047 static int
7048 S_pending_ident(pTHX)
7049 {
7050     dVAR;
7051     register char *d;
7052     PADOFFSET tmp = 0;
7053     /* pit holds the identifier we read and pending_ident is reset */
7054     char pit = PL_pending_ident;
7055     const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7056     /* All routes through this function want to know if there is a colon.  */
7057     const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7058     PL_pending_ident = 0;
7059
7060     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7061     DEBUG_T({ PerlIO_printf(Perl_debug_log,
7062           "### Pending identifier '%s'\n", PL_tokenbuf); });
7063
7064     /* if we're in a my(), we can't allow dynamics here.
7065        $foo'bar has already been turned into $foo::bar, so
7066        just check for colons.
7067
7068        if it's a legal name, the OP is a PADANY.
7069     */
7070     if (PL_in_my) {
7071         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
7072             if (has_colon)
7073                 yyerror(Perl_form(aTHX_ "No package name allowed for "
7074                                   "variable %s in \"our\"",
7075                                   PL_tokenbuf));
7076             tmp = allocmy(PL_tokenbuf);
7077         }
7078         else {
7079             if (has_colon)
7080                 yyerror(Perl_form(aTHX_ PL_no_myglob,
7081                             PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7082
7083             pl_yylval.opval = newOP(OP_PADANY, 0);
7084             pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7085             return PRIVATEREF;
7086         }
7087     }
7088
7089     /*
7090        build the ops for accesses to a my() variable.
7091
7092        Deny my($a) or my($b) in a sort block, *if* $a or $b is
7093        then used in a comparison.  This catches most, but not
7094        all cases.  For instance, it catches
7095            sort { my($a); $a <=> $b }
7096        but not
7097            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7098        (although why you'd do that is anyone's guess).
7099     */
7100
7101     if (!has_colon) {
7102         if (!PL_in_my)
7103             tmp = pad_findmy(PL_tokenbuf);
7104         if (tmp != NOT_IN_PAD) {
7105             /* might be an "our" variable" */
7106             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7107                 /* build ops for a bareword */
7108                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
7109                 HEK * const stashname = HvNAME_HEK(stash);
7110                 SV *  const sym = newSVhek(stashname);
7111                 sv_catpvs(sym, "::");
7112                 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7113                 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7114                 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7115                 gv_fetchsv(sym,
7116                     (PL_in_eval
7117                         ? (GV_ADDMULTI | GV_ADDINEVAL)
7118                         : GV_ADDMULTI
7119                     ),
7120                     ((PL_tokenbuf[0] == '$') ? SVt_PV
7121                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7122                      : SVt_PVHV));
7123                 return WORD;
7124             }
7125
7126             /* if it's a sort block and they're naming $a or $b */
7127             if (PL_last_lop_op == OP_SORT &&
7128                 PL_tokenbuf[0] == '$' &&
7129                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7130                 && !PL_tokenbuf[2])
7131             {
7132                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7133                      d < PL_bufend && *d != '\n';
7134                      d++)
7135                 {
7136                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7137                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7138                               PL_tokenbuf);
7139                     }
7140                 }
7141             }
7142
7143             pl_yylval.opval = newOP(OP_PADANY, 0);
7144             pl_yylval.opval->op_targ = tmp;
7145             return PRIVATEREF;
7146         }
7147     }
7148
7149     /*
7150        Whine if they've said @foo in a doublequoted string,
7151        and @foo isn't a variable we can find in the symbol
7152        table.
7153     */
7154     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7155         GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7156                                          SVt_PVAV);
7157         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7158                 && ckWARN(WARN_AMBIGUOUS)
7159                 /* DO NOT warn for @- and @+ */
7160                 && !( PL_tokenbuf[2] == '\0' &&
7161                     ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7162            )
7163         {
7164             /* Downgraded from fatal to warning 20000522 mjd */
7165             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7166                         "Possible unintended interpolation of %s in string",
7167                          PL_tokenbuf);
7168         }
7169     }
7170
7171     /* build ops for a bareword */
7172     pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7173                                                       tokenbuf_len - 1));
7174     pl_yylval.opval->op_private = OPpCONST_ENTERED;
7175     gv_fetchpvn_flags(
7176             PL_tokenbuf + 1, tokenbuf_len - 1,
7177             /* If the identifier refers to a stash, don't autovivify it.
7178              * Change 24660 had the side effect of causing symbol table
7179              * hashes to always be defined, even if they were freshly
7180              * created and the only reference in the entire program was
7181              * the single statement with the defined %foo::bar:: test.
7182              * It appears that all code in the wild doing this actually
7183              * wants to know whether sub-packages have been loaded, so
7184              * by avoiding auto-vivifying symbol tables, we ensure that
7185              * defined %foo::bar:: continues to be false, and the existing
7186              * tests still give the expected answers, even though what
7187              * they're actually testing has now changed subtly.
7188              */
7189             (*PL_tokenbuf == '%'
7190              && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7191              && d[-1] == ':'
7192              ? 0
7193              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7194             ((PL_tokenbuf[0] == '$') ? SVt_PV
7195              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7196              : SVt_PVHV));
7197     return WORD;
7198 }
7199
7200 /*
7201  *  The following code was generated by perl_keyword.pl.
7202  */
7203
7204 I32
7205 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7206 {
7207     dVAR;
7208
7209     PERL_ARGS_ASSERT_KEYWORD;
7210
7211   switch (len)
7212   {
7213     case 1: /* 5 tokens of length 1 */
7214       switch (name[0])
7215       {
7216         case 'm':
7217           {                                       /* m          */
7218             return KEY_m;
7219           }
7220
7221         case 'q':
7222           {                                       /* q          */
7223             return KEY_q;
7224           }
7225
7226         case 's':
7227           {                                       /* s          */
7228             return KEY_s;
7229           }
7230
7231         case 'x':
7232           {                                       /* x          */
7233             return -KEY_x;
7234           }
7235
7236         case 'y':
7237           {                                       /* y          */
7238             return KEY_y;
7239           }
7240
7241         default:
7242           goto unknown;
7243       }
7244
7245     case 2: /* 18 tokens of length 2 */
7246       switch (name[0])
7247       {
7248         case 'd':
7249           if (name[1] == 'o')
7250           {                                       /* do         */
7251             return KEY_do;
7252           }
7253
7254           goto unknown;
7255
7256         case 'e':
7257           if (name[1] == 'q')
7258           {                                       /* eq         */
7259             return -KEY_eq;
7260           }
7261
7262           goto unknown;
7263
7264         case 'g':
7265           switch (name[1])
7266           {
7267             case 'e':
7268               {                                   /* ge         */
7269                 return -KEY_ge;
7270               }
7271
7272             case 't':
7273               {                                   /* gt         */
7274                 return -KEY_gt;
7275               }
7276
7277             default:
7278               goto unknown;
7279           }
7280
7281         case 'i':
7282           if (name[1] == 'f')
7283           {                                       /* if         */
7284             return KEY_if;
7285           }
7286
7287           goto unknown;
7288
7289         case 'l':
7290           switch (name[1])
7291           {
7292             case 'c':
7293               {                                   /* lc         */
7294                 return -KEY_lc;
7295               }
7296
7297             case 'e':
7298               {                                   /* le         */
7299                 return -KEY_le;
7300               }
7301
7302             case 't':
7303               {                                   /* lt         */
7304                 return -KEY_lt;
7305               }
7306
7307             default:
7308               goto unknown;
7309           }
7310
7311         case 'm':
7312           if (name[1] == 'y')
7313           {                                       /* my         */
7314             return KEY_my;
7315           }
7316
7317           goto unknown;
7318
7319         case 'n':
7320           switch (name[1])
7321           {
7322             case 'e':
7323               {                                   /* ne         */
7324                 return -KEY_ne;
7325               }
7326
7327             case 'o':
7328               {                                   /* no         */
7329                 return KEY_no;
7330               }
7331
7332             default:
7333               goto unknown;
7334           }
7335
7336         case 'o':
7337           if (name[1] == 'r')
7338           {                                       /* or         */
7339             return -KEY_or;
7340           }
7341
7342           goto unknown;
7343
7344         case 'q':
7345           switch (name[1])
7346           {
7347             case 'q':
7348               {                                   /* qq         */
7349                 return KEY_qq;
7350               }
7351
7352             case 'r':
7353               {                                   /* qr         */
7354                 return KEY_qr;
7355               }
7356
7357             case 'w':
7358               {                                   /* qw         */
7359                 return KEY_qw;
7360               }
7361
7362             case 'x':
7363               {                                   /* qx         */
7364                 return KEY_qx;
7365               }
7366
7367             default:
7368               goto unknown;
7369           }
7370
7371         case 't':
7372           if (name[1] == 'r')
7373           {                                       /* tr         */
7374             return KEY_tr;
7375           }
7376
7377           goto unknown;
7378
7379         case 'u':
7380           if (name[1] == 'c')
7381           {                                       /* uc         */
7382             return -KEY_uc;
7383           }
7384
7385           goto unknown;
7386
7387         default:
7388           goto unknown;
7389       }
7390
7391     case 3: /* 29 tokens of length 3 */
7392       switch (name[0])
7393       {
7394         case 'E':
7395           if (name[1] == 'N' &&
7396               name[2] == 'D')
7397           {                                       /* END        */
7398             return KEY_END;
7399           }
7400
7401           goto unknown;
7402
7403         case 'a':
7404           switch (name[1])
7405           {
7406             case 'b':
7407               if (name[2] == 's')
7408               {                                   /* abs        */
7409                 return -KEY_abs;
7410               }
7411
7412               goto unknown;
7413
7414             case 'n':
7415               if (name[2] == 'd')
7416               {                                   /* and        */
7417                 return -KEY_and;
7418               }
7419
7420               goto unknown;
7421
7422             default:
7423               goto unknown;
7424           }
7425
7426         case 'c':
7427           switch (name[1])
7428           {
7429             case 'h':
7430               if (name[2] == 'r')
7431               {                                   /* chr        */
7432                 return -KEY_chr;
7433               }
7434
7435               goto unknown;
7436
7437             case 'm':
7438               if (name[2] == 'p')
7439               {                                   /* cmp        */
7440                 return -KEY_cmp;
7441               }
7442
7443               goto unknown;
7444
7445             case 'o':
7446               if (name[2] == 's')
7447               {                                   /* cos        */
7448                 return -KEY_cos;
7449               }
7450
7451               goto unknown;
7452
7453             default:
7454               goto unknown;
7455           }
7456
7457         case 'd':
7458           if (name[1] == 'i' &&
7459               name[2] == 'e')
7460           {                                       /* die        */
7461             return -KEY_die;
7462           }
7463
7464           goto unknown;
7465
7466         case 'e':
7467           switch (name[1])
7468           {
7469             case 'o':
7470               if (name[2] == 'f')
7471               {                                   /* eof        */
7472                 return -KEY_eof;
7473               }
7474
7475               goto unknown;
7476
7477             case 'x':
7478               if (name[2] == 'p')
7479               {                                   /* exp        */
7480                 return -KEY_exp;
7481               }
7482
7483               goto unknown;
7484
7485             default:
7486               goto unknown;
7487           }
7488
7489         case 'f':
7490           if (name[1] == 'o' &&
7491               name[2] == 'r')
7492           {                                       /* for        */
7493             return KEY_for;
7494           }
7495
7496           goto unknown;
7497
7498         case 'h':
7499           if (name[1] == 'e' &&
7500               name[2] == 'x')
7501           {                                       /* hex        */
7502             return -KEY_hex;
7503           }
7504
7505           goto unknown;
7506
7507         case 'i':
7508           if (name[1] == 'n' &&
7509               name[2] == 't')
7510           {                                       /* int        */
7511             return -KEY_int;
7512           }
7513
7514           goto unknown;
7515
7516         case 'l':
7517           if (name[1] == 'o' &&
7518               name[2] == 'g')
7519           {                                       /* log        */
7520             return -KEY_log;
7521           }
7522
7523           goto unknown;
7524
7525         case 'm':
7526           if (name[1] == 'a' &&
7527               name[2] == 'p')
7528           {                                       /* map        */
7529             return KEY_map;
7530           }
7531
7532           goto unknown;
7533
7534         case 'n':
7535           if (name[1] == 'o' &&
7536               name[2] == 't')
7537           {                                       /* not        */
7538             return -KEY_not;
7539           }
7540
7541           goto unknown;
7542
7543         case 'o':
7544           switch (name[1])
7545           {
7546             case 'c':
7547               if (name[2] == 't')
7548               {                                   /* oct        */
7549                 return -KEY_oct;
7550               }
7551
7552               goto unknown;
7553
7554             case 'r':
7555               if (name[2] == 'd')
7556               {                                   /* ord        */
7557                 return -KEY_ord;
7558               }
7559
7560               goto unknown;
7561
7562             case 'u':
7563               if (name[2] == 'r')
7564               {                                   /* our        */
7565                 return KEY_our;
7566               }
7567
7568               goto unknown;
7569
7570             default:
7571               goto unknown;
7572           }
7573
7574         case 'p':
7575           if (name[1] == 'o')
7576           {
7577             switch (name[2])
7578             {
7579               case 'p':
7580                 {                                 /* pop        */
7581                   return -KEY_pop;
7582                 }
7583
7584               case 's':
7585                 {                                 /* pos        */
7586                   return KEY_pos;
7587                 }
7588
7589               default:
7590                 goto unknown;
7591             }
7592           }
7593
7594           goto unknown;
7595
7596         case 'r':
7597           if (name[1] == 'e' &&
7598               name[2] == 'f')
7599           {                                       /* ref        */
7600             return -KEY_ref;
7601           }
7602
7603           goto unknown;
7604
7605         case 's':
7606           switch (name[1])
7607           {
7608             case 'a':
7609               if (name[2] == 'y')
7610               {                                   /* say        */
7611                 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7612               }
7613
7614               goto unknown;
7615
7616             case 'i':
7617               if (name[2] == 'n')
7618               {                                   /* sin        */
7619                 return -KEY_sin;
7620               }
7621
7622               goto unknown;
7623
7624             case 'u':
7625               if (name[2] == 'b')
7626               {                                   /* sub        */
7627                 return KEY_sub;
7628               }
7629
7630               goto unknown;
7631
7632             default:
7633               goto unknown;
7634           }
7635
7636         case 't':
7637           if (name[1] == 'i' &&
7638               name[2] == 'e')
7639           {                                       /* tie        */
7640             return KEY_tie;
7641           }
7642
7643           goto unknown;
7644
7645         case 'u':
7646           if (name[1] == 's' &&
7647               name[2] == 'e')
7648           {                                       /* use        */
7649             return KEY_use;
7650           }
7651
7652           goto unknown;
7653
7654         case 'v':
7655           if (name[1] == 'e' &&
7656               name[2] == 'c')
7657           {                                       /* vec        */
7658             return -KEY_vec;
7659           }
7660
7661           goto unknown;
7662
7663         case 'x':
7664           if (name[1] == 'o' &&
7665               name[2] == 'r')
7666           {                                       /* xor        */
7667             return -KEY_xor;
7668           }
7669
7670           goto unknown;
7671
7672         default:
7673           goto unknown;
7674       }
7675
7676     case 4: /* 41 tokens of length 4 */
7677       switch (name[0])
7678       {
7679         case 'C':
7680           if (name[1] == 'O' &&
7681               name[2] == 'R' &&
7682               name[3] == 'E')
7683           {                                       /* CORE       */
7684             return -KEY_CORE;
7685           }
7686
7687           goto unknown;
7688
7689         case 'I':
7690           if (name[1] == 'N' &&
7691               name[2] == 'I' &&
7692               name[3] == 'T')
7693           {                                       /* INIT       */
7694             return KEY_INIT;
7695           }
7696
7697           goto unknown;
7698
7699         case 'b':
7700           if (name[1] == 'i' &&
7701               name[2] == 'n' &&
7702               name[3] == 'd')
7703           {                                       /* bind       */
7704             return -KEY_bind;
7705           }
7706
7707           goto unknown;
7708
7709         case 'c':
7710           if (name[1] == 'h' &&
7711               name[2] == 'o' &&
7712               name[3] == 'p')
7713           {                                       /* chop       */
7714             return -KEY_chop;
7715           }
7716
7717           goto unknown;
7718
7719         case 'd':
7720           if (name[1] == 'u' &&
7721               name[2] == 'm' &&
7722               name[3] == 'p')
7723           {                                       /* dump       */
7724             return -KEY_dump;
7725           }
7726
7727           goto unknown;
7728
7729         case 'e':
7730           switch (name[1])
7731           {
7732             case 'a':
7733               if (name[2] == 'c' &&
7734                   name[3] == 'h')
7735               {                                   /* each       */
7736                 return -KEY_each;
7737               }
7738
7739               goto unknown;
7740
7741             case 'l':
7742               if (name[2] == 's' &&
7743                   name[3] == 'e')
7744               {                                   /* else       */
7745                 return KEY_else;
7746               }
7747
7748               goto unknown;
7749
7750             case 'v':
7751               if (name[2] == 'a' &&
7752                   name[3] == 'l')
7753               {                                   /* eval       */
7754                 return KEY_eval;
7755               }
7756
7757               goto unknown;
7758
7759             case 'x':
7760               switch (name[2])
7761               {
7762                 case 'e':
7763                   if (name[3] == 'c')
7764                   {                               /* exec       */
7765                     return -KEY_exec;
7766                   }
7767
7768                   goto unknown;
7769
7770                 case 'i':
7771                   if (name[3] == 't')
7772                   {                               /* exit       */
7773                     return -KEY_exit;
7774                   }
7775
7776                   goto unknown;
7777
7778                 default:
7779                   goto unknown;
7780               }
7781
7782             default:
7783               goto unknown;
7784           }
7785
7786         case 'f':
7787           if (name[1] == 'o' &&
7788               name[2] == 'r' &&
7789               name[3] == 'k')
7790           {                                       /* fork       */
7791             return -KEY_fork;
7792           }
7793
7794           goto unknown;
7795
7796         case 'g':
7797           switch (name[1])
7798           {
7799             case 'e':
7800               if (name[2] == 't' &&
7801                   name[3] == 'c')
7802               {                                   /* getc       */
7803                 return -KEY_getc;
7804               }
7805
7806               goto unknown;
7807
7808             case 'l':
7809               if (name[2] == 'o' &&
7810                   name[3] == 'b')
7811               {                                   /* glob       */
7812                 return KEY_glob;
7813               }
7814
7815               goto unknown;
7816
7817             case 'o':
7818               if (name[2] == 't' &&
7819                   name[3] == 'o')
7820               {                                   /* goto       */
7821                 return KEY_goto;
7822               }
7823
7824               goto unknown;
7825
7826             case 'r':
7827               if (name[2] == 'e' &&
7828                   name[3] == 'p')
7829               {                                   /* grep       */
7830                 return KEY_grep;
7831               }
7832
7833               goto unknown;
7834
7835             default:
7836               goto unknown;
7837           }
7838
7839         case 'j':
7840           if (name[1] == 'o' &&
7841               name[2] == 'i' &&
7842               name[3] == 'n')
7843           {                                       /* join       */
7844             return -KEY_join;
7845           }
7846
7847           goto unknown;
7848
7849         case 'k':
7850           switch (name[1])
7851           {
7852             case 'e':
7853               if (name[2] == 'y' &&
7854                   name[3] == 's')
7855               {                                   /* keys       */
7856                 return -KEY_keys;
7857               }
7858
7859               goto unknown;
7860
7861             case 'i':
7862               if (name[2] == 'l' &&
7863                   name[3] == 'l')
7864               {                                   /* kill       */
7865                 return -KEY_kill;
7866               }
7867
7868               goto unknown;
7869
7870             default:
7871               goto unknown;
7872           }
7873
7874         case 'l':
7875           switch (name[1])
7876           {
7877             case 'a':
7878               if (name[2] == 's' &&
7879                   name[3] == 't')
7880               {                                   /* last       */
7881                 return KEY_last;
7882               }
7883
7884               goto unknown;
7885
7886             case 'i':
7887               if (name[2] == 'n' &&
7888                   name[3] == 'k')
7889               {                                   /* link       */
7890                 return -KEY_link;
7891               }
7892
7893               goto unknown;
7894
7895             case 'o':
7896               if (name[2] == 'c' &&
7897                   name[3] == 'k')
7898               {                                   /* lock       */
7899                 return -KEY_lock;
7900               }
7901
7902               goto unknown;
7903
7904             default:
7905               goto unknown;
7906           }
7907
7908         case 'n':
7909           if (name[1] == 'e' &&
7910               name[2] == 'x' &&
7911               name[3] == 't')
7912           {                                       /* next       */
7913             return KEY_next;
7914           }
7915
7916           goto unknown;
7917
7918         case 'o':
7919           if (name[1] == 'p' &&
7920               name[2] == 'e' &&
7921               name[3] == 'n')
7922           {                                       /* open       */
7923             return -KEY_open;
7924           }
7925
7926           goto unknown;
7927
7928         case 'p':
7929           switch (name[1])
7930           {
7931             case 'a':
7932               if (name[2] == 'c' &&
7933                   name[3] == 'k')
7934               {                                   /* pack       */
7935                 return -KEY_pack;
7936               }
7937
7938               goto unknown;
7939
7940             case 'i':
7941               if (name[2] == 'p' &&
7942                   name[3] == 'e')
7943               {                                   /* pipe       */
7944                 return -KEY_pipe;
7945               }
7946
7947               goto unknown;
7948
7949             case 'u':
7950               if (name[2] == 's' &&
7951                   name[3] == 'h')
7952               {                                   /* push       */
7953                 return -KEY_push;
7954               }
7955
7956               goto unknown;
7957
7958             default:
7959               goto unknown;
7960           }
7961
7962         case 'r':
7963           switch (name[1])
7964           {
7965             case 'a':
7966               if (name[2] == 'n' &&
7967                   name[3] == 'd')
7968               {                                   /* rand       */
7969                 return -KEY_rand;
7970               }
7971
7972               goto unknown;
7973
7974             case 'e':
7975               switch (name[2])
7976               {
7977                 case 'a':
7978                   if (name[3] == 'd')
7979                   {                               /* read       */
7980                     return -KEY_read;
7981                   }
7982
7983                   goto unknown;
7984
7985                 case 'c':
7986                   if (name[3] == 'v')
7987                   {                               /* recv       */
7988                     return -KEY_recv;
7989                   }
7990
7991                   goto unknown;
7992
7993                 case 'd':
7994                   if (name[3] == 'o')
7995                   {                               /* redo       */
7996                     return KEY_redo;
7997                   }
7998
7999                   goto unknown;
8000
8001                 default:
8002                   goto unknown;
8003               }
8004
8005             default:
8006               goto unknown;
8007           }
8008
8009         case 's':
8010           switch (name[1])
8011           {
8012             case 'e':
8013               switch (name[2])
8014               {
8015                 case 'e':
8016                   if (name[3] == 'k')
8017                   {                               /* seek       */
8018                     return -KEY_seek;
8019                   }
8020
8021                   goto unknown;
8022
8023                 case 'n':
8024                   if (name[3] == 'd')
8025                   {                               /* send       */
8026                     return -KEY_send;
8027                   }
8028
8029                   goto unknown;
8030
8031                 default:
8032                   goto unknown;
8033               }
8034
8035             case 'o':
8036               if (name[2] == 'r' &&
8037                   name[3] == 't')
8038               {                                   /* sort       */
8039                 return KEY_sort;
8040               }
8041
8042               goto unknown;
8043
8044             case 'q':
8045               if (name[2] == 'r' &&
8046                   name[3] == 't')
8047               {                                   /* sqrt       */
8048                 return -KEY_sqrt;
8049               }
8050
8051               goto unknown;
8052
8053             case 't':
8054               if (name[2] == 'a' &&
8055                   name[3] == 't')
8056               {                                   /* stat       */
8057                 return -KEY_stat;
8058               }
8059
8060               goto unknown;
8061
8062             default:
8063               goto unknown;
8064           }
8065
8066         case 't':
8067           switch (name[1])
8068           {
8069             case 'e':
8070               if (name[2] == 'l' &&
8071                   name[3] == 'l')
8072               {                                   /* tell       */
8073                 return -KEY_tell;
8074               }
8075
8076               goto unknown;
8077
8078             case 'i':
8079               switch (name[2])
8080               {
8081                 case 'e':
8082                   if (name[3] == 'd')
8083                   {                               /* tied       */
8084                     return KEY_tied;
8085                   }
8086
8087                   goto unknown;
8088
8089                 case 'm':
8090                   if (name[3] == 'e')
8091                   {                               /* time       */
8092                     return -KEY_time;
8093                   }
8094
8095                   goto unknown;
8096
8097                 default:
8098                   goto unknown;
8099               }
8100
8101             default:
8102               goto unknown;
8103           }
8104
8105         case 'w':
8106           switch (name[1])
8107           {
8108             case 'a':
8109               switch (name[2])
8110               {
8111                 case 'i':
8112                   if (name[3] == 't')
8113                   {                               /* wait       */
8114                     return -KEY_wait;
8115                   }
8116
8117                   goto unknown;
8118
8119                 case 'r':
8120                   if (name[3] == 'n')
8121                   {                               /* warn       */
8122                     return -KEY_warn;
8123                   }
8124
8125                   goto unknown;
8126
8127                 default:
8128                   goto unknown;
8129               }
8130
8131             case 'h':
8132               if (name[2] == 'e' &&
8133                   name[3] == 'n')
8134               {                                   /* when       */
8135                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8136               }
8137
8138               goto unknown;
8139
8140             default:
8141               goto unknown;
8142           }
8143
8144         default:
8145           goto unknown;
8146       }
8147
8148     case 5: /* 39 tokens of length 5 */
8149       switch (name[0])
8150       {
8151         case 'B':
8152           if (name[1] == 'E' &&
8153               name[2] == 'G' &&
8154               name[3] == 'I' &&
8155               name[4] == 'N')
8156           {                                       /* BEGIN      */
8157             return KEY_BEGIN;
8158           }
8159
8160           goto unknown;
8161
8162         case 'C':
8163           if (name[1] == 'H' &&
8164               name[2] == 'E' &&
8165               name[3] == 'C' &&
8166               name[4] == 'K')
8167           {                                       /* CHECK      */
8168             return KEY_CHECK;
8169           }
8170
8171           goto unknown;
8172
8173         case 'a':
8174           switch (name[1])
8175           {
8176             case 'l':
8177               if (name[2] == 'a' &&
8178                   name[3] == 'r' &&
8179                   name[4] == 'm')
8180               {                                   /* alarm      */
8181                 return -KEY_alarm;
8182               }
8183
8184               goto unknown;
8185
8186             case 't':
8187               if (name[2] == 'a' &&
8188                   name[3] == 'n' &&
8189                   name[4] == '2')
8190               {                                   /* atan2      */
8191                 return -KEY_atan2;
8192               }
8193
8194               goto unknown;
8195
8196             default:
8197               goto unknown;
8198           }
8199
8200         case 'b':
8201           switch (name[1])
8202           {
8203             case 'l':
8204               if (name[2] == 'e' &&
8205                   name[3] == 's' &&
8206                   name[4] == 's')
8207               {                                   /* bless      */
8208                 return -KEY_bless;
8209               }
8210
8211               goto unknown;
8212
8213             case 'r':
8214               if (name[2] == 'e' &&
8215                   name[3] == 'a' &&
8216                   name[4] == 'k')
8217               {                                   /* break      */
8218                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8219               }
8220
8221               goto unknown;
8222
8223             default:
8224               goto unknown;
8225           }
8226
8227         case 'c':
8228           switch (name[1])
8229           {
8230             case 'h':
8231               switch (name[2])
8232               {
8233                 case 'd':
8234                   if (name[3] == 'i' &&
8235                       name[4] == 'r')
8236                   {                               /* chdir      */
8237                     return -KEY_chdir;
8238                   }
8239
8240                   goto unknown;
8241
8242                 case 'm':
8243                   if (name[3] == 'o' &&
8244                       name[4] == 'd')
8245                   {                               /* chmod      */
8246                     return -KEY_chmod;
8247                   }
8248
8249                   goto unknown;
8250
8251                 case 'o':
8252                   switch (name[3])
8253                   {
8254                     case 'm':
8255                       if (name[4] == 'p')
8256                       {                           /* chomp      */
8257                         return -KEY_chomp;
8258                       }
8259
8260                       goto unknown;
8261
8262                     case 'w':
8263                       if (name[4] == 'n')
8264                       {                           /* chown      */
8265                         return -KEY_chown;
8266                       }
8267
8268                       goto unknown;
8269
8270                     default:
8271                       goto unknown;
8272                   }
8273
8274                 default:
8275                   goto unknown;
8276               }
8277
8278             case 'l':
8279               if (name[2] == 'o' &&
8280                   name[3] == 's' &&
8281                   name[4] == 'e')
8282               {                                   /* close      */
8283                 return -KEY_close;
8284               }
8285
8286               goto unknown;
8287
8288             case 'r':
8289               if (name[2] == 'y' &&
8290                   name[3] == 'p' &&
8291                   name[4] == 't')
8292               {                                   /* crypt      */
8293                 return -KEY_crypt;
8294               }
8295
8296               goto unknown;
8297
8298             default:
8299               goto unknown;
8300           }
8301
8302         case 'e':
8303           if (name[1] == 'l' &&
8304               name[2] == 's' &&
8305               name[3] == 'i' &&
8306               name[4] == 'f')
8307           {                                       /* elsif      */
8308             return KEY_elsif;
8309           }
8310
8311           goto unknown;
8312
8313         case 'f':
8314           switch (name[1])
8315           {
8316             case 'c':
8317               if (name[2] == 'n' &&
8318                   name[3] == 't' &&
8319                   name[4] == 'l')
8320               {                                   /* fcntl      */
8321                 return -KEY_fcntl;
8322               }
8323
8324               goto unknown;
8325
8326             case 'l':
8327               if (name[2] == 'o' &&
8328                   name[3] == 'c' &&
8329                   name[4] == 'k')
8330               {                                   /* flock      */
8331                 return -KEY_flock;
8332               }
8333
8334               goto unknown;
8335
8336             default:
8337               goto unknown;
8338           }
8339
8340         case 'g':
8341           if (name[1] == 'i' &&
8342               name[2] == 'v' &&
8343               name[3] == 'e' &&
8344               name[4] == 'n')
8345           {                                       /* given      */
8346             return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8347           }
8348
8349           goto unknown;
8350
8351         case 'i':
8352           switch (name[1])
8353           {
8354             case 'n':
8355               if (name[2] == 'd' &&
8356                   name[3] == 'e' &&
8357                   name[4] == 'x')
8358               {                                   /* index      */
8359                 return -KEY_index;
8360               }
8361
8362               goto unknown;
8363
8364             case 'o':
8365               if (name[2] == 'c' &&
8366                   name[3] == 't' &&
8367                   name[4] == 'l')
8368               {                                   /* ioctl      */
8369                 return -KEY_ioctl;
8370               }
8371
8372               goto unknown;
8373
8374             default:
8375               goto unknown;
8376           }
8377
8378         case 'l':
8379           switch (name[1])
8380           {
8381             case 'o':
8382               if (name[2] == 'c' &&
8383                   name[3] == 'a' &&
8384                   name[4] == 'l')
8385               {                                   /* local      */
8386                 return KEY_local;
8387               }
8388
8389               goto unknown;
8390
8391             case 's':
8392               if (name[2] == 't' &&
8393                   name[3] == 'a' &&
8394                   name[4] == 't')
8395               {                                   /* lstat      */
8396                 return -KEY_lstat;
8397               }
8398
8399               goto unknown;
8400
8401             default:
8402               goto unknown;
8403           }
8404
8405         case 'm':
8406           if (name[1] == 'k' &&
8407               name[2] == 'd' &&
8408               name[3] == 'i' &&
8409               name[4] == 'r')
8410           {                                       /* mkdir      */
8411             return -KEY_mkdir;
8412           }
8413
8414           goto unknown;
8415
8416         case 'p':
8417           if (name[1] == 'r' &&
8418               name[2] == 'i' &&
8419               name[3] == 'n' &&
8420               name[4] == 't')
8421           {                                       /* print      */
8422             return KEY_print;
8423           }
8424
8425           goto unknown;
8426
8427         case 'r':
8428           switch (name[1])
8429           {
8430             case 'e':
8431               if (name[2] == 's' &&
8432                   name[3] == 'e' &&
8433                   name[4] == 't')
8434               {                                   /* reset      */
8435                 return -KEY_reset;
8436               }
8437
8438               goto unknown;
8439
8440             case 'm':
8441               if (name[2] == 'd' &&
8442                   name[3] == 'i' &&
8443                   name[4] == 'r')
8444               {                                   /* rmdir      */
8445                 return -KEY_rmdir;
8446               }
8447
8448               goto unknown;
8449
8450             default:
8451               goto unknown;
8452           }
8453
8454         case 's':
8455           switch (name[1])
8456           {
8457             case 'e':
8458               if (name[2] == 'm' &&
8459                   name[3] == 'o' &&
8460                   name[4] == 'p')
8461               {                                   /* semop      */
8462                 return -KEY_semop;
8463               }
8464
8465               goto unknown;
8466
8467             case 'h':
8468               if (name[2] == 'i' &&
8469                   name[3] == 'f' &&
8470                   name[4] == 't')
8471               {                                   /* shift      */
8472                 return -KEY_shift;
8473               }
8474
8475               goto unknown;
8476
8477             case 'l':
8478               if (name[2] == 'e' &&
8479                   name[3] == 'e' &&
8480                   name[4] == 'p')
8481               {                                   /* sleep      */
8482                 return -KEY_sleep;
8483               }
8484
8485               goto unknown;
8486
8487             case 'p':
8488               if (name[2] == 'l' &&
8489                   name[3] == 'i' &&
8490                   name[4] == 't')
8491               {                                   /* split      */
8492                 return KEY_split;
8493               }
8494
8495               goto unknown;
8496
8497             case 'r':
8498               if (name[2] == 'a' &&
8499                   name[3] == 'n' &&
8500                   name[4] == 'd')
8501               {                                   /* srand      */
8502                 return -KEY_srand;
8503               }
8504
8505               goto unknown;
8506
8507             case 't':
8508               switch (name[2])
8509               {
8510                 case 'a':
8511                   if (name[3] == 't' &&
8512                       name[4] == 'e')
8513                   {                               /* state      */
8514                     return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8515                   }
8516
8517                   goto unknown;
8518
8519                 case 'u':
8520                   if (name[3] == 'd' &&
8521                       name[4] == 'y')
8522                   {                               /* study      */
8523                     return KEY_study;
8524                   }
8525
8526                   goto unknown;
8527
8528                 default:
8529                   goto unknown;
8530               }
8531
8532             default:
8533               goto unknown;
8534           }
8535
8536         case 't':
8537           if (name[1] == 'i' &&
8538               name[2] == 'm' &&
8539               name[3] == 'e' &&
8540               name[4] == 's')
8541           {                                       /* times      */
8542             return -KEY_times;
8543           }
8544
8545           goto unknown;
8546
8547         case 'u':
8548           switch (name[1])
8549           {
8550             case 'm':
8551               if (name[2] == 'a' &&
8552                   name[3] == 's' &&
8553                   name[4] == 'k')
8554               {                                   /* umask      */
8555                 return -KEY_umask;
8556               }
8557
8558               goto unknown;
8559
8560             case 'n':
8561               switch (name[2])
8562               {
8563                 case 'd':
8564                   if (name[3] == 'e' &&
8565                       name[4] == 'f')
8566                   {                               /* undef      */
8567                     return KEY_undef;
8568                   }
8569
8570                   goto unknown;
8571
8572                 case 't':
8573                   if (name[3] == 'i')
8574                   {
8575                     switch (name[4])
8576                     {
8577                       case 'e':
8578                         {                         /* untie      */
8579                           return KEY_untie;
8580                         }
8581
8582                       case 'l':
8583                         {                         /* until      */
8584                           return KEY_until;
8585                         }
8586
8587                       default:
8588                         goto unknown;
8589                     }
8590                   }
8591
8592                   goto unknown;
8593
8594                 default:
8595                   goto unknown;
8596               }
8597
8598             case 't':
8599               if (name[2] == 'i' &&
8600                   name[3] == 'm' &&
8601                   name[4] == 'e')
8602               {                                   /* utime      */
8603                 return -KEY_utime;
8604               }
8605
8606               goto unknown;
8607
8608             default:
8609               goto unknown;
8610           }
8611
8612         case 'w':
8613           switch (name[1])
8614           {
8615             case 'h':
8616               if (name[2] == 'i' &&
8617                   name[3] == 'l' &&
8618                   name[4] == 'e')
8619               {                                   /* while      */
8620                 return KEY_while;
8621               }
8622
8623               goto unknown;
8624
8625             case 'r':
8626               if (name[2] == 'i' &&
8627                   name[3] == 't' &&
8628                   name[4] == 'e')
8629               {                                   /* write      */
8630                 return -KEY_write;
8631               }
8632
8633               goto unknown;
8634
8635             default:
8636               goto unknown;
8637           }
8638
8639         default:
8640           goto unknown;
8641       }
8642
8643     case 6: /* 33 tokens of length 6 */
8644       switch (name[0])
8645       {
8646         case 'a':
8647           if (name[1] == 'c' &&
8648               name[2] == 'c' &&
8649               name[3] == 'e' &&
8650               name[4] == 'p' &&
8651               name[5] == 't')
8652           {                                       /* accept     */
8653             return -KEY_accept;
8654           }
8655
8656           goto unknown;
8657
8658         case 'c':
8659           switch (name[1])
8660           {
8661             case 'a':
8662               if (name[2] == 'l' &&
8663                   name[3] == 'l' &&
8664                   name[4] == 'e' &&
8665                   name[5] == 'r')
8666               {                                   /* caller     */
8667                 return -KEY_caller;
8668               }
8669
8670               goto unknown;
8671
8672             case 'h':
8673               if (name[2] == 'r' &&
8674                   name[3] == 'o' &&
8675                   name[4] == 'o' &&
8676                   name[5] == 't')
8677               {                                   /* chroot     */
8678                 return -KEY_chroot;
8679               }
8680
8681               goto unknown;
8682
8683             default:
8684               goto unknown;
8685           }
8686
8687         case 'd':
8688           if (name[1] == 'e' &&
8689               name[2] == 'l' &&
8690               name[3] == 'e' &&
8691               name[4] == 't' &&
8692               name[5] == 'e')
8693           {                                       /* delete     */
8694             return KEY_delete;
8695           }
8696
8697           goto unknown;
8698
8699         case 'e':
8700           switch (name[1])
8701           {
8702             case 'l':
8703               if (name[2] == 's' &&
8704                   name[3] == 'e' &&
8705                   name[4] == 'i' &&
8706                   name[5] == 'f')
8707               {                                   /* elseif     */
8708                 if(ckWARN_d(WARN_SYNTAX))
8709                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8710               }
8711
8712               goto unknown;
8713
8714             case 'x':
8715               if (name[2] == 'i' &&
8716                   name[3] == 's' &&
8717                   name[4] == 't' &&
8718                   name[5] == 's')
8719               {                                   /* exists     */
8720                 return KEY_exists;
8721               }
8722
8723               goto unknown;
8724
8725             default:
8726               goto unknown;
8727           }
8728
8729         case 'f':
8730           switch (name[1])
8731           {
8732             case 'i':
8733               if (name[2] == 'l' &&
8734                   name[3] == 'e' &&
8735                   name[4] == 'n' &&
8736                   name[5] == 'o')
8737               {                                   /* fileno     */
8738                 return -KEY_fileno;
8739               }
8740
8741               goto unknown;
8742
8743             case 'o':
8744               if (name[2] == 'r' &&
8745                   name[3] == 'm' &&
8746                   name[4] == 'a' &&
8747                   name[5] == 't')
8748               {                                   /* format     */
8749                 return KEY_format;
8750               }
8751
8752               goto unknown;
8753
8754             default:
8755               goto unknown;
8756           }
8757
8758         case 'g':
8759           if (name[1] == 'm' &&
8760               name[2] == 't' &&
8761               name[3] == 'i' &&
8762               name[4] == 'm' &&
8763               name[5] == 'e')
8764           {                                       /* gmtime     */
8765             return -KEY_gmtime;
8766           }
8767
8768           goto unknown;
8769
8770         case 'l':
8771           switch (name[1])
8772           {
8773             case 'e':
8774               if (name[2] == 'n' &&
8775                   name[3] == 'g' &&
8776                   name[4] == 't' &&
8777                   name[5] == 'h')
8778               {                                   /* length     */
8779                 return -KEY_length;
8780               }
8781
8782               goto unknown;
8783
8784             case 'i':
8785               if (name[2] == 's' &&
8786                   name[3] == 't' &&
8787                   name[4] == 'e' &&
8788                   name[5] == 'n')
8789               {                                   /* listen     */
8790                 return -KEY_listen;
8791               }
8792
8793               goto unknown;
8794
8795             default:
8796               goto unknown;
8797           }
8798
8799         case 'm':
8800           if (name[1] == 's' &&
8801               name[2] == 'g')
8802           {
8803             switch (name[3])
8804             {
8805               case 'c':
8806                 if (name[4] == 't' &&
8807                     name[5] == 'l')
8808                 {                                 /* msgctl     */
8809                   return -KEY_msgctl;
8810                 }
8811
8812                 goto unknown;
8813
8814               case 'g':
8815                 if (name[4] == 'e' &&
8816                     name[5] == 't')
8817                 {                                 /* msgget     */
8818                   return -KEY_msgget;
8819                 }
8820
8821                 goto unknown;
8822
8823               case 'r':
8824                 if (name[4] == 'c' &&
8825                     name[5] == 'v')
8826                 {                                 /* msgrcv     */
8827                   return -KEY_msgrcv;
8828                 }
8829
8830                 goto unknown;
8831
8832               case 's':
8833                 if (name[4] == 'n' &&
8834                     name[5] == 'd')
8835                 {                                 /* msgsnd     */
8836                   return -KEY_msgsnd;
8837                 }
8838
8839                 goto unknown;
8840
8841               default:
8842                 goto unknown;
8843             }
8844           }
8845
8846           goto unknown;
8847
8848         case 'p':
8849           if (name[1] == 'r' &&
8850               name[2] == 'i' &&
8851               name[3] == 'n' &&
8852               name[4] == 't' &&
8853               name[5] == 'f')
8854           {                                       /* printf     */
8855             return KEY_printf;
8856           }
8857
8858           goto unknown;
8859
8860         case 'r':
8861           switch (name[1])
8862           {
8863             case 'e':
8864               switch (name[2])
8865               {
8866                 case 'n':
8867                   if (name[3] == 'a' &&
8868                       name[4] == 'm' &&
8869                       name[5] == 'e')
8870                   {                               /* rename     */
8871                     return -KEY_rename;
8872                   }
8873
8874                   goto unknown;
8875
8876                 case 't':
8877                   if (name[3] == 'u' &&
8878                       name[4] == 'r' &&
8879                       name[5] == 'n')
8880                   {                               /* return     */
8881                     return KEY_return;
8882                   }
8883
8884                   goto unknown;
8885
8886                 default:
8887                   goto unknown;
8888               }
8889
8890             case 'i':
8891               if (name[2] == 'n' &&
8892                   name[3] == 'd' &&
8893                   name[4] == 'e' &&
8894                   name[5] == 'x')
8895               {                                   /* rindex     */
8896                 return -KEY_rindex;
8897               }
8898
8899               goto unknown;
8900
8901             default:
8902               goto unknown;
8903           }
8904
8905         case 's':
8906           switch (name[1])
8907           {
8908             case 'c':
8909               if (name[2] == 'a' &&
8910                   name[3] == 'l' &&
8911                   name[4] == 'a' &&
8912                   name[5] == 'r')
8913               {                                   /* scalar     */
8914                 return KEY_scalar;
8915               }
8916
8917               goto unknown;
8918
8919             case 'e':
8920               switch (name[2])
8921               {
8922                 case 'l':
8923                   if (name[3] == 'e' &&
8924                       name[4] == 'c' &&
8925                       name[5] == 't')
8926                   {                               /* select     */
8927                     return -KEY_select;
8928                   }
8929
8930                   goto unknown;
8931
8932                 case 'm':
8933                   switch (name[3])
8934                   {
8935                     case 'c':
8936                       if (name[4] == 't' &&
8937                           name[5] == 'l')
8938                       {                           /* semctl     */
8939                         return -KEY_semctl;
8940                       }
8941
8942                       goto unknown;
8943
8944                     case 'g':
8945                       if (name[4] == 'e' &&
8946                           name[5] == 't')
8947                       {                           /* semget     */
8948                         return -KEY_semget;
8949                       }
8950
8951                       goto unknown;
8952
8953                     default:
8954                       goto unknown;
8955                   }
8956
8957                 default:
8958                   goto unknown;
8959               }
8960
8961             case 'h':
8962               if (name[2] == 'm')
8963               {
8964                 switch (name[3])
8965                 {
8966                   case 'c':
8967                     if (name[4] == 't' &&
8968                         name[5] == 'l')
8969                     {                             /* shmctl     */
8970                       return -KEY_shmctl;
8971                     }
8972
8973                     goto unknown;
8974
8975                   case 'g':
8976                     if (name[4] == 'e' &&
8977                         name[5] == 't')
8978                     {                             /* shmget     */
8979                       return -KEY_shmget;
8980                     }
8981
8982                     goto unknown;
8983
8984                   default:
8985                     goto unknown;
8986                 }
8987               }
8988
8989               goto unknown;
8990
8991             case 'o':
8992               if (name[2] == 'c' &&
8993                   name[3] == 'k' &&
8994                   name[4] == 'e' &&
8995                   name[5] == 't')
8996               {                                   /* socket     */
8997                 return -KEY_socket;
8998               }
8999
9000               goto unknown;
9001
9002             case 'p':
9003               if (name[2] == 'l' &&
9004                   name[3] == 'i' &&
9005                   name[4] == 'c' &&
9006                   name[5] == 'e')
9007               {                                   /* splice     */
9008                 return -KEY_splice;
9009               }
9010
9011               goto unknown;
9012
9013             case 'u':
9014               if (name[2] == 'b' &&
9015                   name[3] == 's' &&
9016                   name[4] == 't' &&
9017                   name[5] == 'r')
9018               {                                   /* substr     */
9019                 return -KEY_substr;
9020               }
9021
9022               goto unknown;
9023
9024             case 'y':
9025               if (name[2] == 's' &&
9026                   name[3] == 't' &&
9027                   name[4] == 'e' &&
9028                   name[5] == 'm')
9029               {                                   /* system     */
9030                 return -KEY_system;
9031               }
9032
9033               goto unknown;
9034
9035             default:
9036               goto unknown;
9037           }
9038
9039         case 'u':
9040           if (name[1] == 'n')
9041           {
9042             switch (name[2])
9043             {
9044               case 'l':
9045                 switch (name[3])
9046                 {
9047                   case 'e':
9048                     if (name[4] == 's' &&
9049                         name[5] == 's')
9050                     {                             /* unless     */
9051                       return KEY_unless;
9052                     }
9053
9054                     goto unknown;
9055
9056                   case 'i':
9057                     if (name[4] == 'n' &&
9058                         name[5] == 'k')
9059                     {                             /* unlink     */
9060                       return -KEY_unlink;
9061                     }
9062
9063                     goto unknown;
9064
9065                   default:
9066                     goto unknown;
9067                 }
9068
9069               case 'p':
9070                 if (name[3] == 'a' &&
9071                     name[4] == 'c' &&
9072                     name[5] == 'k')
9073                 {                                 /* unpack     */
9074                   return -KEY_unpack;
9075                 }
9076
9077                 goto unknown;
9078
9079               default:
9080                 goto unknown;
9081             }
9082           }
9083
9084           goto unknown;
9085
9086         case 'v':
9087           if (name[1] == 'a' &&
9088               name[2] == 'l' &&
9089               name[3] == 'u' &&
9090               name[4] == 'e' &&
9091               name[5] == 's')
9092           {                                       /* values     */
9093             return -KEY_values;
9094           }
9095
9096           goto unknown;
9097
9098         default:
9099           goto unknown;
9100       }
9101
9102     case 7: /* 29 tokens of length 7 */
9103       switch (name[0])
9104       {
9105         case 'D':
9106           if (name[1] == 'E' &&
9107               name[2] == 'S' &&
9108               name[3] == 'T' &&
9109               name[4] == 'R' &&
9110               name[5] == 'O' &&
9111               name[6] == 'Y')
9112           {                                       /* DESTROY    */
9113             return KEY_DESTROY;
9114           }
9115
9116           goto unknown;
9117
9118         case '_':
9119           if (name[1] == '_' &&
9120               name[2] == 'E' &&
9121               name[3] == 'N' &&
9122               name[4] == 'D' &&
9123               name[5] == '_' &&
9124               name[6] == '_')
9125           {                                       /* __END__    */
9126             return KEY___END__;
9127           }
9128
9129           goto unknown;
9130
9131         case 'b':
9132           if (name[1] == 'i' &&
9133               name[2] == 'n' &&
9134               name[3] == 'm' &&
9135               name[4] == 'o' &&
9136               name[5] == 'd' &&
9137               name[6] == 'e')
9138           {                                       /* binmode    */
9139             return -KEY_binmode;
9140           }
9141
9142           goto unknown;
9143
9144         case 'c':
9145           if (name[1] == 'o' &&
9146               name[2] == 'n' &&
9147               name[3] == 'n' &&
9148               name[4] == 'e' &&
9149               name[5] == 'c' &&
9150               name[6] == 't')
9151           {                                       /* connect    */
9152             return -KEY_connect;
9153           }
9154
9155           goto unknown;
9156
9157         case 'd':
9158           switch (name[1])
9159           {
9160             case 'b':
9161               if (name[2] == 'm' &&
9162                   name[3] == 'o' &&
9163                   name[4] == 'p' &&
9164                   name[5] == 'e' &&
9165                   name[6] == 'n')
9166               {                                   /* dbmopen    */
9167                 return -KEY_dbmopen;
9168               }
9169
9170               goto unknown;
9171
9172             case 'e':
9173               if (name[2] == 'f')
9174               {
9175                 switch (name[3])
9176                 {
9177                   case 'a':
9178                     if (name[4] == 'u' &&
9179                         name[5] == 'l' &&
9180                         name[6] == 't')
9181                     {                             /* default    */
9182                       return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9183                     }
9184
9185                     goto unknown;
9186
9187                   case 'i':
9188                     if (name[4] == 'n' &&
9189                         name[5] == 'e' &&
9190                         name[6] == 'd')
9191                     {                             /* defined    */
9192                       return KEY_defined;
9193                     }
9194
9195                     goto unknown;
9196
9197                   default:
9198                     goto unknown;
9199                 }
9200               }
9201
9202               goto unknown;
9203
9204             default:
9205               goto unknown;
9206           }
9207
9208         case 'f':
9209           if (name[1] == 'o' &&
9210               name[2] == 'r' &&
9211               name[3] == 'e' &&
9212               name[4] == 'a' &&
9213               name[5] == 'c' &&
9214               name[6] == 'h')
9215           {                                       /* foreach    */
9216             return KEY_foreach;
9217           }
9218
9219           goto unknown;
9220
9221         case 'g':
9222           if (name[1] == 'e' &&
9223               name[2] == 't' &&
9224               name[3] == 'p')
9225           {
9226             switch (name[4])
9227             {
9228               case 'g':
9229                 if (name[5] == 'r' &&
9230                     name[6] == 'p')
9231                 {                                 /* getpgrp    */
9232                   return -KEY_getpgrp;
9233                 }
9234
9235                 goto unknown;
9236
9237               case 'p':
9238                 if (name[5] == 'i' &&
9239                     name[6] == 'd')
9240                 {                                 /* getppid    */
9241                   return -KEY_getppid;
9242                 }
9243
9244                 goto unknown;
9245
9246               default:
9247                 goto unknown;
9248             }
9249           }
9250
9251           goto unknown;
9252
9253         case 'l':
9254           if (name[1] == 'c' &&
9255               name[2] == 'f' &&
9256               name[3] == 'i' &&
9257               name[4] == 'r' &&
9258               name[5] == 's' &&
9259               name[6] == 't')
9260           {                                       /* lcfirst    */
9261             return -KEY_lcfirst;
9262           }
9263
9264           goto unknown;
9265
9266         case 'o':
9267           if (name[1] == 'p' &&
9268               name[2] == 'e' &&
9269               name[3] == 'n' &&
9270               name[4] == 'd' &&
9271               name[5] == 'i' &&
9272               name[6] == 'r')
9273           {                                       /* opendir    */
9274             return -KEY_opendir;
9275           }
9276
9277           goto unknown;
9278
9279         case 'p':
9280           if (name[1] == 'a' &&
9281               name[2] == 'c' &&
9282               name[3] == 'k' &&
9283               name[4] == 'a' &&
9284               name[5] == 'g' &&
9285               name[6] == 'e')
9286           {                                       /* package    */
9287             return KEY_package;
9288           }
9289
9290           goto unknown;
9291
9292         case 'r':
9293           if (name[1] == 'e')
9294           {
9295             switch (name[2])
9296             {
9297               case 'a':
9298                 if (name[3] == 'd' &&
9299                     name[4] == 'd' &&
9300                     name[5] == 'i' &&
9301                     name[6] == 'r')
9302                 {                                 /* readdir    */
9303                   return -KEY_readdir;
9304                 }
9305
9306                 goto unknown;
9307
9308               case 'q':
9309                 if (name[3] == 'u' &&
9310                     name[4] == 'i' &&
9311                     name[5] == 'r' &&
9312                     name[6] == 'e')
9313                 {                                 /* require    */
9314                   return KEY_require;
9315                 }
9316
9317                 goto unknown;
9318
9319               case 'v':
9320                 if (name[3] == 'e' &&
9321                     name[4] == 'r' &&
9322                     name[5] == 's' &&
9323                     name[6] == 'e')
9324                 {                                 /* reverse    */
9325                   return -KEY_reverse;
9326                 }
9327
9328                 goto unknown;
9329
9330               default:
9331                 goto unknown;
9332             }
9333           }
9334
9335           goto unknown;
9336
9337         case 's':
9338           switch (name[1])
9339           {
9340             case 'e':
9341               switch (name[2])
9342               {
9343                 case 'e':
9344                   if (name[3] == 'k' &&
9345                       name[4] == 'd' &&
9346                       name[5] == 'i' &&
9347                       name[6] == 'r')
9348                   {                               /* seekdir    */
9349                     return -KEY_seekdir;
9350                   }
9351
9352                   goto unknown;
9353
9354                 case 't':
9355                   if (name[3] == 'p' &&
9356                       name[4] == 'g' &&
9357                       name[5] == 'r' &&
9358                       name[6] == 'p')
9359                   {                               /* setpgrp    */
9360                     return -KEY_setpgrp;
9361                   }
9362
9363                   goto unknown;
9364
9365                 default:
9366                   goto unknown;
9367               }
9368
9369             case 'h':
9370               if (name[2] == 'm' &&
9371                   name[3] == 'r' &&
9372                   name[4] == 'e' &&
9373                   name[5] == 'a' &&
9374                   name[6] == 'd')
9375               {                                   /* shmread    */
9376                 return -KEY_shmread;
9377               }
9378
9379               goto unknown;
9380
9381             case 'p':
9382               if (name[2] == 'r' &&
9383                   name[3] == 'i' &&
9384                   name[4] == 'n' &&
9385                   name[5] == 't' &&
9386                   name[6] == 'f')
9387               {                                   /* sprintf    */
9388                 return -KEY_sprintf;
9389               }
9390
9391               goto unknown;
9392
9393             case 'y':
9394               switch (name[2])
9395               {
9396                 case 'm':
9397                   if (name[3] == 'l' &&
9398                       name[4] == 'i' &&
9399                       name[5] == 'n' &&
9400                       name[6] == 'k')
9401                   {                               /* symlink    */
9402                     return -KEY_symlink;
9403                   }
9404
9405                   goto unknown;
9406
9407                 case 's':
9408                   switch (name[3])
9409                   {
9410                     case 'c':
9411                       if (name[4] == 'a' &&
9412                           name[5] == 'l' &&
9413                           name[6] == 'l')
9414                       {                           /* syscall    */
9415                         return -KEY_syscall;
9416                       }
9417
9418                       goto unknown;
9419
9420                     case 'o':
9421                       if (name[4] == 'p' &&
9422                           name[5] == 'e' &&
9423                           name[6] == 'n')
9424                       {                           /* sysopen    */
9425                         return -KEY_sysopen;
9426                       }
9427
9428                       goto unknown;
9429
9430                     case 'r':
9431                       if (name[4] == 'e' &&
9432                           name[5] == 'a' &&
9433                           name[6] == 'd')
9434                       {                           /* sysread    */
9435                         return -KEY_sysread;
9436                       }
9437
9438                       goto unknown;
9439
9440                     case 's':
9441                       if (name[4] == 'e' &&
9442                           name[5] == 'e' &&
9443                           name[6] == 'k')
9444                       {                           /* sysseek    */
9445                         return -KEY_sysseek;
9446                       }
9447
9448                       goto unknown;
9449
9450                     default:
9451                       goto unknown;
9452                   }
9453
9454                 default:
9455                   goto unknown;
9456               }
9457
9458             default:
9459               goto unknown;
9460           }
9461
9462         case 't':
9463           if (name[1] == 'e' &&
9464               name[2] == 'l' &&
9465               name[3] == 'l' &&
9466               name[4] == 'd' &&
9467               name[5] == 'i' &&
9468               name[6] == 'r')
9469           {                                       /* telldir    */
9470             return -KEY_telldir;
9471           }
9472
9473           goto unknown;
9474
9475         case 'u':
9476           switch (name[1])
9477           {
9478             case 'c':
9479               if (name[2] == 'f' &&
9480                   name[3] == 'i' &&
9481                   name[4] == 'r' &&
9482                   name[5] == 's' &&
9483                   name[6] == 't')
9484               {                                   /* ucfirst    */
9485                 return -KEY_ucfirst;
9486               }
9487
9488               goto unknown;
9489
9490             case 'n':
9491               if (name[2] == 's' &&
9492                   name[3] == 'h' &&
9493                   name[4] == 'i' &&
9494                   name[5] == 'f' &&
9495                   name[6] == 't')
9496               {                                   /* unshift    */
9497                 return -KEY_unshift;
9498               }
9499
9500               goto unknown;
9501
9502             default:
9503               goto unknown;
9504           }
9505
9506         case 'w':
9507           if (name[1] == 'a' &&
9508               name[2] == 'i' &&
9509               name[3] == 't' &&
9510               name[4] == 'p' &&
9511               name[5] == 'i' &&
9512               name[6] == 'd')
9513           {                                       /* waitpid    */
9514             return -KEY_waitpid;
9515           }
9516
9517           goto unknown;
9518
9519         default:
9520           goto unknown;
9521       }
9522
9523     case 8: /* 26 tokens of length 8 */
9524       switch (name[0])
9525       {
9526         case 'A':
9527           if (name[1] == 'U' &&
9528               name[2] == 'T' &&
9529               name[3] == 'O' &&
9530               name[4] == 'L' &&
9531               name[5] == 'O' &&
9532               name[6] == 'A' &&
9533               name[7] == 'D')
9534           {                                       /* AUTOLOAD   */
9535             return KEY_AUTOLOAD;
9536           }
9537
9538           goto unknown;
9539
9540         case '_':
9541           if (name[1] == '_')
9542           {
9543             switch (name[2])
9544             {
9545               case 'D':
9546                 if (name[3] == 'A' &&
9547                     name[4] == 'T' &&
9548                     name[5] == 'A' &&
9549                     name[6] == '_' &&
9550                     name[7] == '_')
9551                 {                                 /* __DATA__   */
9552                   return KEY___DATA__;
9553                 }
9554
9555                 goto unknown;
9556
9557               case 'F':
9558                 if (name[3] == 'I' &&
9559                     name[4] == 'L' &&
9560                     name[5] == 'E' &&
9561                     name[6] == '_' &&
9562                     name[7] == '_')
9563                 {                                 /* __FILE__   */
9564                   return -KEY___FILE__;
9565                 }
9566
9567                 goto unknown;
9568
9569               case 'L':
9570                 if (name[3] == 'I' &&
9571                     name[4] == 'N' &&
9572                     name[5] == 'E' &&
9573                     name[6] == '_' &&
9574                     name[7] == '_')
9575                 {                                 /* __LINE__   */
9576                   return -KEY___LINE__;
9577                 }
9578
9579                 goto unknown;
9580
9581               default:
9582                 goto unknown;
9583             }
9584           }
9585
9586           goto unknown;
9587
9588         case 'c':
9589           switch (name[1])
9590           {
9591             case 'l':
9592               if (name[2] == 'o' &&
9593                   name[3] == 's' &&
9594                   name[4] == 'e' &&
9595                   name[5] == 'd' &&
9596                   name[6] == 'i' &&
9597                   name[7] == 'r')
9598               {                                   /* closedir   */
9599                 return -KEY_closedir;
9600               }
9601
9602               goto unknown;
9603
9604             case 'o':
9605               if (name[2] == 'n' &&
9606                   name[3] == 't' &&
9607                   name[4] == 'i' &&
9608                   name[5] == 'n' &&
9609                   name[6] == 'u' &&
9610                   name[7] == 'e')
9611               {                                   /* continue   */
9612                 return -KEY_continue;
9613               }
9614
9615               goto unknown;
9616
9617             default:
9618               goto unknown;
9619           }
9620
9621         case 'd':
9622           if (name[1] == 'b' &&
9623               name[2] == 'm' &&
9624               name[3] == 'c' &&
9625               name[4] == 'l' &&
9626               name[5] == 'o' &&
9627               name[6] == 's' &&
9628               name[7] == 'e')
9629           {                                       /* dbmclose   */
9630             return -KEY_dbmclose;
9631           }
9632
9633           goto unknown;
9634
9635         case 'e':
9636           if (name[1] == 'n' &&
9637               name[2] == 'd')
9638           {
9639             switch (name[3])
9640             {
9641               case 'g':
9642                 if (name[4] == 'r' &&
9643                     name[5] == 'e' &&
9644                     name[6] == 'n' &&
9645                     name[7] == 't')
9646                 {                                 /* endgrent   */
9647                   return -KEY_endgrent;
9648                 }
9649
9650                 goto unknown;
9651
9652               case 'p':
9653                 if (name[4] == 'w' &&
9654                     name[5] == 'e' &&
9655                     name[6] == 'n' &&
9656                     name[7] == 't')
9657                 {                                 /* endpwent   */
9658                   return -KEY_endpwent;
9659                 }
9660
9661                 goto unknown;
9662
9663               default:
9664                 goto unknown;
9665             }
9666           }
9667
9668           goto unknown;
9669
9670         case 'f':
9671           if (name[1] == 'o' &&
9672               name[2] == 'r' &&
9673               name[3] == 'm' &&
9674               name[4] == 'l' &&
9675               name[5] == 'i' &&
9676               name[6] == 'n' &&
9677               name[7] == 'e')
9678           {                                       /* formline   */
9679             return -KEY_formline;
9680           }
9681
9682           goto unknown;
9683
9684         case 'g':
9685           if (name[1] == 'e' &&
9686               name[2] == 't')
9687           {
9688             switch (name[3])
9689             {
9690               case 'g':
9691                 if (name[4] == 'r')
9692                 {
9693                   switch (name[5])
9694                   {
9695                     case 'e':
9696                       if (name[6] == 'n' &&
9697                           name[7] == 't')
9698                       {                           /* getgrent   */
9699                         return -KEY_getgrent;
9700                       }
9701
9702                       goto unknown;
9703
9704                     case 'g':
9705                       if (name[6] == 'i' &&
9706                           name[7] == 'd')
9707                       {                           /* getgrgid   */
9708                         return -KEY_getgrgid;
9709                       }
9710
9711                       goto unknown;
9712
9713                     case 'n':
9714                       if (name[6] == 'a' &&
9715                           name[7] == 'm')
9716                       {                           /* getgrnam   */
9717                         return -KEY_getgrnam;
9718                       }
9719
9720                       goto unknown;
9721
9722                     default:
9723                       goto unknown;
9724                   }
9725                 }
9726
9727                 goto unknown;
9728
9729               case 'l':
9730                 if (name[4] == 'o' &&
9731                     name[5] == 'g' &&
9732                     name[6] == 'i' &&
9733                     name[7] == 'n')
9734                 {                                 /* getlogin   */
9735                   return -KEY_getlogin;
9736                 }
9737
9738                 goto unknown;
9739
9740               case 'p':
9741                 if (name[4] == 'w')
9742                 {
9743                   switch (name[5])
9744                   {
9745                     case 'e':
9746                       if (name[6] == 'n' &&
9747                           name[7] == 't')
9748                       {                           /* getpwent   */
9749                         return -KEY_getpwent;
9750                       }
9751
9752                       goto unknown;
9753
9754                     case 'n':
9755                       if (name[6] == 'a' &&
9756                           name[7] == 'm')
9757                       {                           /* getpwnam   */
9758                         return -KEY_getpwnam;
9759                       }
9760
9761                       goto unknown;
9762
9763                     case 'u':
9764                       if (name[6] == 'i' &&
9765                           name[7] == 'd')
9766                       {                           /* getpwuid   */
9767                         return -KEY_getpwuid;
9768                       }
9769
9770                       goto unknown;
9771
9772                     default:
9773                       goto unknown;
9774                   }
9775                 }
9776
9777                 goto unknown;
9778
9779               default:
9780                 goto unknown;
9781             }
9782           }
9783
9784           goto unknown;
9785
9786         case 'r':
9787           if (name[1] == 'e' &&
9788               name[2] == 'a' &&
9789               name[3] == 'd')
9790           {
9791             switch (name[4])
9792             {
9793               case 'l':
9794                 if (name[5] == 'i' &&
9795                     name[6] == 'n')
9796                 {
9797                   switch (name[7])
9798                   {
9799                     case 'e':
9800                       {                           /* readline   */
9801                         return -KEY_readline;
9802                       }
9803
9804                     case 'k':
9805                       {                           /* readlink   */
9806                         return -KEY_readlink;
9807                       }
9808
9809                     default:
9810                       goto unknown;
9811                   }
9812                 }
9813
9814                 goto unknown;
9815
9816               case 'p':
9817                 if (name[5] == 'i' &&
9818                     name[6] == 'p' &&
9819                     name[7] == 'e')
9820                 {                                 /* readpipe   */
9821                   return -KEY_readpipe;
9822                 }
9823
9824                 goto unknown;
9825
9826               default:
9827                 goto unknown;
9828             }
9829           }
9830
9831           goto unknown;
9832
9833         case 's':
9834           switch (name[1])
9835           {
9836             case 'e':
9837               if (name[2] == 't')
9838               {
9839                 switch (name[3])
9840                 {
9841                   case 'g':
9842                     if (name[4] == 'r' &&
9843                         name[5] == 'e' &&
9844                         name[6] == 'n' &&
9845                         name[7] == 't')
9846                     {                             /* setgrent   */
9847                       return -KEY_setgrent;
9848                     }
9849
9850                     goto unknown;
9851
9852                   case 'p':
9853                     if (name[4] == 'w' &&
9854                         name[5] == 'e' &&
9855                         name[6] == 'n' &&
9856                         name[7] == 't')
9857                     {                             /* setpwent   */
9858                       return -KEY_setpwent;
9859                     }
9860
9861                     goto unknown;
9862
9863                   default:
9864                     goto unknown;
9865                 }
9866               }
9867
9868               goto unknown;
9869
9870             case 'h':
9871               switch (name[2])
9872               {
9873                 case 'm':
9874                   if (name[3] == 'w' &&
9875                       name[4] == 'r' &&
9876                       name[5] == 'i' &&
9877                       name[6] == 't' &&
9878                       name[7] == 'e')
9879                   {                               /* shmwrite   */
9880                     return -KEY_shmwrite;
9881                   }
9882
9883                   goto unknown;
9884
9885                 case 'u':
9886                   if (name[3] == 't' &&
9887                       name[4] == 'd' &&
9888                       name[5] == 'o' &&
9889                       name[6] == 'w' &&
9890                       name[7] == 'n')
9891                   {                               /* shutdown   */
9892                     return -KEY_shutdown;
9893                   }
9894
9895                   goto unknown;
9896
9897                 default:
9898                   goto unknown;
9899               }
9900
9901             case 'y':
9902               if (name[2] == 's' &&
9903                   name[3] == 'w' &&
9904                   name[4] == 'r' &&
9905                   name[5] == 'i' &&
9906                   name[6] == 't' &&
9907                   name[7] == 'e')
9908               {                                   /* syswrite   */
9909                 return -KEY_syswrite;
9910               }
9911
9912               goto unknown;
9913
9914             default:
9915               goto unknown;
9916           }
9917
9918         case 't':
9919           if (name[1] == 'r' &&
9920               name[2] == 'u' &&
9921               name[3] == 'n' &&
9922               name[4] == 'c' &&
9923               name[5] == 'a' &&
9924               name[6] == 't' &&
9925               name[7] == 'e')
9926           {                                       /* truncate   */
9927             return -KEY_truncate;
9928           }
9929
9930           goto unknown;
9931
9932         default:
9933           goto unknown;
9934       }
9935
9936     case 9: /* 9 tokens of length 9 */
9937       switch (name[0])
9938       {
9939         case 'U':
9940           if (name[1] == 'N' &&
9941               name[2] == 'I' &&
9942               name[3] == 'T' &&
9943               name[4] == 'C' &&
9944               name[5] == 'H' &&
9945               name[6] == 'E' &&
9946               name[7] == 'C' &&
9947               name[8] == 'K')
9948           {                                       /* UNITCHECK  */
9949             return KEY_UNITCHECK;
9950           }
9951
9952           goto unknown;
9953
9954         case 'e':
9955           if (name[1] == 'n' &&
9956               name[2] == 'd' &&
9957               name[3] == 'n' &&
9958               name[4] == 'e' &&
9959               name[5] == 't' &&
9960               name[6] == 'e' &&
9961               name[7] == 'n' &&
9962               name[8] == 't')
9963           {                                       /* endnetent  */
9964             return -KEY_endnetent;
9965           }
9966
9967           goto unknown;
9968
9969         case 'g':
9970           if (name[1] == 'e' &&
9971               name[2] == 't' &&
9972               name[3] == 'n' &&
9973               name[4] == 'e' &&
9974               name[5] == 't' &&
9975               name[6] == 'e' &&
9976               name[7] == 'n' &&
9977               name[8] == 't')
9978           {                                       /* getnetent  */
9979             return -KEY_getnetent;
9980           }
9981
9982           goto unknown;
9983
9984         case 'l':
9985           if (name[1] == 'o' &&
9986               name[2] == 'c' &&
9987               name[3] == 'a' &&
9988               name[4] == 'l' &&
9989               name[5] == 't' &&
9990               name[6] == 'i' &&
9991               name[7] == 'm' &&
9992               name[8] == 'e')
9993           {                                       /* localtime  */
9994             return -KEY_localtime;
9995           }
9996
9997           goto unknown;
9998
9999         case 'p':
10000           if (name[1] == 'r' &&
10001               name[2] == 'o' &&
10002               name[3] == 't' &&
10003               name[4] == 'o' &&
10004               name[5] == 't' &&
10005               name[6] == 'y' &&
10006               name[7] == 'p' &&
10007               name[8] == 'e')
10008           {                                       /* prototype  */
10009             return KEY_prototype;
10010           }
10011
10012           goto unknown;
10013
10014         case 'q':
10015           if (name[1] == 'u' &&
10016               name[2] == 'o' &&
10017               name[3] == 't' &&
10018               name[4] == 'e' &&
10019               name[5] == 'm' &&
10020               name[6] == 'e' &&
10021               name[7] == 't' &&
10022               name[8] == 'a')
10023           {                                       /* quotemeta  */
10024             return -KEY_quotemeta;
10025           }
10026
10027           goto unknown;
10028
10029         case 'r':
10030           if (name[1] == 'e' &&
10031               name[2] == 'w' &&
10032               name[3] == 'i' &&
10033               name[4] == 'n' &&
10034               name[5] == 'd' &&
10035               name[6] == 'd' &&
10036               name[7] == 'i' &&
10037               name[8] == 'r')
10038           {                                       /* rewinddir  */
10039             return -KEY_rewinddir;
10040           }
10041
10042           goto unknown;
10043
10044         case 's':
10045           if (name[1] == 'e' &&
10046               name[2] == 't' &&
10047               name[3] == 'n' &&
10048               name[4] == 'e' &&
10049               name[5] == 't' &&
10050               name[6] == 'e' &&
10051               name[7] == 'n' &&
10052               name[8] == 't')
10053           {                                       /* setnetent  */
10054             return -KEY_setnetent;
10055           }
10056
10057           goto unknown;
10058
10059         case 'w':
10060           if (name[1] == 'a' &&
10061               name[2] == 'n' &&
10062               name[3] == 't' &&
10063               name[4] == 'a' &&
10064               name[5] == 'r' &&
10065               name[6] == 'r' &&
10066               name[7] == 'a' &&
10067               name[8] == 'y')
10068           {                                       /* wantarray  */
10069             return -KEY_wantarray;
10070           }
10071
10072           goto unknown;
10073
10074         default:
10075           goto unknown;
10076       }
10077
10078     case 10: /* 9 tokens of length 10 */
10079       switch (name[0])
10080       {
10081         case 'e':
10082           if (name[1] == 'n' &&
10083               name[2] == 'd')
10084           {
10085             switch (name[3])
10086             {
10087               case 'h':
10088                 if (name[4] == 'o' &&
10089                     name[5] == 's' &&
10090                     name[6] == 't' &&
10091                     name[7] == 'e' &&
10092                     name[8] == 'n' &&
10093                     name[9] == 't')
10094                 {                                 /* endhostent */
10095                   return -KEY_endhostent;
10096                 }
10097
10098                 goto unknown;
10099
10100               case 's':
10101                 if (name[4] == 'e' &&
10102                     name[5] == 'r' &&
10103                     name[6] == 'v' &&
10104                     name[7] == 'e' &&
10105                     name[8] == 'n' &&
10106                     name[9] == 't')
10107                 {                                 /* endservent */
10108                   return -KEY_endservent;
10109                 }
10110
10111                 goto unknown;
10112
10113               default:
10114                 goto unknown;
10115             }
10116           }
10117
10118           goto unknown;
10119
10120         case 'g':
10121           if (name[1] == 'e' &&
10122               name[2] == 't')
10123           {
10124             switch (name[3])
10125             {
10126               case 'h':
10127                 if (name[4] == 'o' &&
10128                     name[5] == 's' &&
10129                     name[6] == 't' &&
10130                     name[7] == 'e' &&
10131                     name[8] == 'n' &&
10132                     name[9] == 't')
10133                 {                                 /* gethostent */
10134                   return -KEY_gethostent;
10135                 }
10136
10137                 goto unknown;
10138
10139               case 's':
10140                 switch (name[4])
10141                 {
10142                   case 'e':
10143                     if (name[5] == 'r' &&
10144                         name[6] == 'v' &&
10145                         name[7] == 'e' &&
10146                         name[8] == 'n' &&
10147                         name[9] == 't')
10148                     {                             /* getservent */
10149                       return -KEY_getservent;
10150                     }
10151
10152                     goto unknown;
10153
10154                   case 'o':
10155                     if (name[5] == 'c' &&
10156                         name[6] == 'k' &&
10157                         name[7] == 'o' &&
10158                         name[8] == 'p' &&
10159                         name[9] == 't')
10160                     {                             /* getsockopt */
10161                       return -KEY_getsockopt;
10162                     }
10163
10164                     goto unknown;
10165
10166                   default:
10167                     goto unknown;
10168                 }
10169
10170               default:
10171                 goto unknown;
10172             }
10173           }
10174
10175           goto unknown;
10176
10177         case 's':
10178           switch (name[1])
10179           {
10180             case 'e':
10181               if (name[2] == 't')
10182               {
10183                 switch (name[3])
10184                 {
10185                   case 'h':
10186                     if (name[4] == 'o' &&
10187                         name[5] == 's' &&
10188                         name[6] == 't' &&
10189                         name[7] == 'e' &&
10190                         name[8] == 'n' &&
10191                         name[9] == 't')
10192                     {                             /* sethostent */
10193                       return -KEY_sethostent;
10194                     }
10195
10196                     goto unknown;
10197
10198                   case 's':
10199                     switch (name[4])
10200                     {
10201                       case 'e':
10202                         if (name[5] == 'r' &&
10203                             name[6] == 'v' &&
10204                             name[7] == 'e' &&
10205                             name[8] == 'n' &&
10206                             name[9] == 't')
10207                         {                         /* setservent */
10208                           return -KEY_setservent;
10209                         }
10210
10211                         goto unknown;
10212
10213                       case 'o':
10214                         if (name[5] == 'c' &&
10215                             name[6] == 'k' &&
10216                             name[7] == 'o' &&
10217                             name[8] == 'p' &&
10218                             name[9] == 't')
10219                         {                         /* setsockopt */
10220                           return -KEY_setsockopt;
10221                         }
10222
10223                         goto unknown;
10224
10225                       default:
10226                         goto unknown;
10227                     }
10228
10229                   default:
10230                     goto unknown;
10231                 }
10232               }
10233
10234               goto unknown;
10235
10236             case 'o':
10237               if (name[2] == 'c' &&
10238                   name[3] == 'k' &&
10239                   name[4] == 'e' &&
10240                   name[5] == 't' &&
10241                   name[6] == 'p' &&
10242                   name[7] == 'a' &&
10243                   name[8] == 'i' &&
10244                   name[9] == 'r')
10245               {                                   /* socketpair */
10246                 return -KEY_socketpair;
10247               }
10248
10249               goto unknown;
10250
10251             default:
10252               goto unknown;
10253           }
10254
10255         default:
10256           goto unknown;
10257       }
10258
10259     case 11: /* 8 tokens of length 11 */
10260       switch (name[0])
10261       {
10262         case '_':
10263           if (name[1] == '_' &&
10264               name[2] == 'P' &&
10265               name[3] == 'A' &&
10266               name[4] == 'C' &&
10267               name[5] == 'K' &&
10268               name[6] == 'A' &&
10269               name[7] == 'G' &&
10270               name[8] == 'E' &&
10271               name[9] == '_' &&
10272               name[10] == '_')
10273           {                                       /* __PACKAGE__ */
10274             return -KEY___PACKAGE__;
10275           }
10276
10277           goto unknown;
10278
10279         case 'e':
10280           if (name[1] == 'n' &&
10281               name[2] == 'd' &&
10282               name[3] == 'p' &&
10283               name[4] == 'r' &&
10284               name[5] == 'o' &&
10285               name[6] == 't' &&
10286               name[7] == 'o' &&
10287               name[8] == 'e' &&
10288               name[9] == 'n' &&
10289               name[10] == 't')
10290           {                                       /* endprotoent */
10291             return -KEY_endprotoent;
10292           }
10293
10294           goto unknown;
10295
10296         case 'g':
10297           if (name[1] == 'e' &&
10298               name[2] == 't')
10299           {
10300             switch (name[3])
10301             {
10302               case 'p':
10303                 switch (name[4])
10304                 {
10305                   case 'e':
10306                     if (name[5] == 'e' &&
10307                         name[6] == 'r' &&
10308                         name[7] == 'n' &&
10309                         name[8] == 'a' &&
10310                         name[9] == 'm' &&
10311                         name[10] == 'e')
10312                     {                             /* getpeername */
10313                       return -KEY_getpeername;
10314                     }
10315
10316                     goto unknown;
10317
10318                   case 'r':
10319                     switch (name[5])
10320                     {
10321                       case 'i':
10322                         if (name[6] == 'o' &&
10323                             name[7] == 'r' &&
10324                             name[8] == 'i' &&
10325                             name[9] == 't' &&
10326                             name[10] == 'y')
10327                         {                         /* getpriority */
10328                           return -KEY_getpriority;
10329                         }
10330
10331                         goto unknown;
10332
10333                       case 'o':
10334                         if (name[6] == 't' &&
10335                             name[7] == 'o' &&
10336                             name[8] == 'e' &&
10337                             name[9] == 'n' &&
10338                             name[10] == 't')
10339                         {                         /* getprotoent */
10340                           return -KEY_getprotoent;
10341                         }
10342
10343                         goto unknown;
10344
10345                       default:
10346                         goto unknown;
10347                     }
10348
10349                   default:
10350                     goto unknown;
10351                 }
10352
10353               case 's':
10354                 if (name[4] == 'o' &&
10355                     name[5] == 'c' &&
10356                     name[6] == 'k' &&
10357                     name[7] == 'n' &&
10358                     name[8] == 'a' &&
10359                     name[9] == 'm' &&
10360                     name[10] == 'e')
10361                 {                                 /* getsockname */
10362                   return -KEY_getsockname;
10363                 }
10364
10365                 goto unknown;
10366
10367               default:
10368                 goto unknown;
10369             }
10370           }
10371
10372           goto unknown;
10373
10374         case 's':
10375           if (name[1] == 'e' &&
10376               name[2] == 't' &&
10377               name[3] == 'p' &&
10378               name[4] == 'r')
10379           {
10380             switch (name[5])
10381             {
10382               case 'i':
10383                 if (name[6] == 'o' &&
10384                     name[7] == 'r' &&
10385                     name[8] == 'i' &&
10386                     name[9] == 't' &&
10387                     name[10] == 'y')
10388                 {                                 /* setpriority */
10389                   return -KEY_setpriority;
10390                 }
10391
10392                 goto unknown;
10393
10394               case 'o':
10395                 if (name[6] == 't' &&
10396                     name[7] == 'o' &&
10397                     name[8] == 'e' &&
10398                     name[9] == 'n' &&
10399                     name[10] == 't')
10400                 {                                 /* setprotoent */
10401                   return -KEY_setprotoent;
10402                 }
10403
10404                 goto unknown;
10405
10406               default:
10407                 goto unknown;
10408             }
10409           }
10410
10411           goto unknown;
10412
10413         default:
10414           goto unknown;
10415       }
10416
10417     case 12: /* 2 tokens of length 12 */
10418       if (name[0] == 'g' &&
10419           name[1] == 'e' &&
10420           name[2] == 't' &&
10421           name[3] == 'n' &&
10422           name[4] == 'e' &&
10423           name[5] == 't' &&
10424           name[6] == 'b' &&
10425           name[7] == 'y')
10426       {
10427         switch (name[8])
10428         {
10429           case 'a':
10430             if (name[9] == 'd' &&
10431                 name[10] == 'd' &&
10432                 name[11] == 'r')
10433             {                                     /* getnetbyaddr */
10434               return -KEY_getnetbyaddr;
10435             }
10436
10437             goto unknown;
10438
10439           case 'n':
10440             if (name[9] == 'a' &&
10441                 name[10] == 'm' &&
10442                 name[11] == 'e')
10443             {                                     /* getnetbyname */
10444               return -KEY_getnetbyname;
10445             }
10446
10447             goto unknown;
10448
10449           default:
10450             goto unknown;
10451         }
10452       }
10453
10454       goto unknown;
10455
10456     case 13: /* 4 tokens of length 13 */
10457       if (name[0] == 'g' &&
10458           name[1] == 'e' &&
10459           name[2] == 't')
10460       {
10461         switch (name[3])
10462         {
10463           case 'h':
10464             if (name[4] == 'o' &&
10465                 name[5] == 's' &&
10466                 name[6] == 't' &&
10467                 name[7] == 'b' &&
10468                 name[8] == 'y')
10469             {
10470               switch (name[9])
10471               {
10472                 case 'a':
10473                   if (name[10] == 'd' &&
10474                       name[11] == 'd' &&
10475                       name[12] == 'r')
10476                   {                               /* gethostbyaddr */
10477                     return -KEY_gethostbyaddr;
10478                   }
10479
10480                   goto unknown;
10481
10482                 case 'n':
10483                   if (name[10] == 'a' &&
10484                       name[11] == 'm' &&
10485                       name[12] == 'e')
10486                   {                               /* gethostbyname */
10487                     return -KEY_gethostbyname;
10488                   }
10489
10490                   goto unknown;
10491
10492                 default:
10493                   goto unknown;
10494               }
10495             }
10496
10497             goto unknown;
10498
10499           case 's':
10500             if (name[4] == 'e' &&
10501                 name[5] == 'r' &&
10502                 name[6] == 'v' &&
10503                 name[7] == 'b' &&
10504                 name[8] == 'y')
10505             {
10506               switch (name[9])
10507               {
10508                 case 'n':
10509                   if (name[10] == 'a' &&
10510                       name[11] == 'm' &&
10511                       name[12] == 'e')
10512                   {                               /* getservbyname */
10513                     return -KEY_getservbyname;
10514                   }
10515
10516                   goto unknown;
10517
10518                 case 'p':
10519                   if (name[10] == 'o' &&
10520                       name[11] == 'r' &&
10521                       name[12] == 't')
10522                   {                               /* getservbyport */
10523                     return -KEY_getservbyport;
10524                   }
10525
10526                   goto unknown;
10527
10528                 default:
10529                   goto unknown;
10530               }
10531             }
10532
10533             goto unknown;
10534
10535           default:
10536             goto unknown;
10537         }
10538       }
10539
10540       goto unknown;
10541
10542     case 14: /* 1 tokens of length 14 */
10543       if (name[0] == 'g' &&
10544           name[1] == 'e' &&
10545           name[2] == 't' &&
10546           name[3] == 'p' &&
10547           name[4] == 'r' &&
10548           name[5] == 'o' &&
10549           name[6] == 't' &&
10550           name[7] == 'o' &&
10551           name[8] == 'b' &&
10552           name[9] == 'y' &&
10553           name[10] == 'n' &&
10554           name[11] == 'a' &&
10555           name[12] == 'm' &&
10556           name[13] == 'e')
10557       {                                           /* getprotobyname */
10558         return -KEY_getprotobyname;
10559       }
10560
10561       goto unknown;
10562
10563     case 16: /* 1 tokens of length 16 */
10564       if (name[0] == 'g' &&
10565           name[1] == 'e' &&
10566           name[2] == 't' &&
10567           name[3] == 'p' &&
10568           name[4] == 'r' &&
10569           name[5] == 'o' &&
10570           name[6] == 't' &&
10571           name[7] == 'o' &&
10572           name[8] == 'b' &&
10573           name[9] == 'y' &&
10574           name[10] == 'n' &&
10575           name[11] == 'u' &&
10576           name[12] == 'm' &&
10577           name[13] == 'b' &&
10578           name[14] == 'e' &&
10579           name[15] == 'r')
10580       {                                           /* getprotobynumber */
10581         return -KEY_getprotobynumber;
10582       }
10583
10584       goto unknown;
10585
10586     default:
10587       goto unknown;
10588   }
10589
10590 unknown:
10591   return 0;
10592 }
10593
10594 STATIC void
10595 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10596 {
10597     dVAR;
10598
10599     PERL_ARGS_ASSERT_CHECKCOMMA;
10600
10601     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10602         if (ckWARN(WARN_SYNTAX)) {
10603             int level = 1;
10604             const char *w;
10605             for (w = s+2; *w && level; w++) {
10606                 if (*w == '(')
10607                     ++level;
10608                 else if (*w == ')')
10609                     --level;
10610             }
10611             while (isSPACE(*w))
10612                 ++w;
10613             /* the list of chars below is for end of statements or
10614              * block / parens, boolean operators (&&, ||, //) and branch
10615              * constructs (or, and, if, until, unless, while, err, for).
10616              * Not a very solid hack... */
10617             if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10618                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10619                             "%s (...) interpreted as function",name);
10620         }
10621     }
10622     while (s < PL_bufend && isSPACE(*s))
10623         s++;
10624     if (*s == '(')
10625         s++;
10626     while (s < PL_bufend && isSPACE(*s))
10627         s++;
10628     if (isIDFIRST_lazy_if(s,UTF)) {
10629         const char * const w = s++;
10630         while (isALNUM_lazy_if(s,UTF))
10631             s++;
10632         while (s < PL_bufend && isSPACE(*s))
10633             s++;
10634         if (*s == ',') {
10635             GV* gv;
10636             if (keyword(w, s - w, 0))
10637                 return;
10638
10639             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10640             if (gv && GvCVu(gv))
10641                 return;
10642             Perl_croak(aTHX_ "No comma allowed after %s", what);
10643         }
10644     }
10645 }
10646
10647 /* Either returns sv, or mortalizes sv and returns a new SV*.
10648    Best used as sv=new_constant(..., sv, ...).
10649    If s, pv are NULL, calls subroutine with one argument,
10650    and type is used with error messages only. */
10651
10652 STATIC SV *
10653 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10654                SV *sv, SV *pv, const char *type, STRLEN typelen)
10655 {
10656     dVAR; dSP;
10657     HV * const table = GvHV(PL_hintgv);          /* ^H */
10658     SV *res;
10659     SV **cvp;
10660     SV *cv, *typesv;
10661     const char *why1 = "", *why2 = "", *why3 = "";
10662
10663     PERL_ARGS_ASSERT_NEW_CONSTANT;
10664
10665     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10666         SV *msg;
10667
10668         why2 = (const char *)
10669             (strEQ(key,"charnames")
10670              ? "(possibly a missing \"use charnames ...\")"
10671              : "");
10672         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10673                             (type ? type: "undef"), why2);
10674
10675         /* This is convoluted and evil ("goto considered harmful")
10676          * but I do not understand the intricacies of all the different
10677          * failure modes of %^H in here.  The goal here is to make
10678          * the most probable error message user-friendly. --jhi */
10679
10680         goto msgdone;
10681
10682     report:
10683         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10684                             (type ? type: "undef"), why1, why2, why3);
10685     msgdone:
10686         yyerror(SvPVX_const(msg));
10687         SvREFCNT_dec(msg);
10688         return sv;
10689     }
10690     cvp = hv_fetch(table, key, keylen, FALSE);
10691     if (!cvp || !SvOK(*cvp)) {
10692         why1 = "$^H{";
10693         why2 = key;
10694         why3 = "} is not defined";
10695         goto report;
10696     }
10697     sv_2mortal(sv);                     /* Parent created it permanently */
10698     cv = *cvp;
10699     if (!pv && s)
10700         pv = newSVpvn_flags(s, len, SVs_TEMP);
10701     if (type && pv)
10702         typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10703     else
10704         typesv = &PL_sv_undef;
10705
10706     PUSHSTACKi(PERLSI_OVERLOAD);
10707     ENTER ;
10708     SAVETMPS;
10709
10710     PUSHMARK(SP) ;
10711     EXTEND(sp, 3);
10712     if (pv)
10713         PUSHs(pv);
10714     PUSHs(sv);
10715     if (pv)
10716         PUSHs(typesv);
10717     PUTBACK;
10718     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10719
10720     SPAGAIN ;
10721
10722     /* Check the eval first */
10723     if (!PL_in_eval && SvTRUE(ERRSV)) {
10724         sv_catpvs(ERRSV, "Propagated");
10725         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10726         (void)POPs;
10727         res = SvREFCNT_inc_simple(sv);
10728     }
10729     else {
10730         res = POPs;
10731         SvREFCNT_inc_simple_void(res);
10732     }
10733
10734     PUTBACK ;
10735     FREETMPS ;
10736     LEAVE ;
10737     POPSTACK;
10738
10739     if (!SvOK(res)) {
10740         why1 = "Call to &{$^H{";
10741         why2 = key;
10742         why3 = "}} did not return a defined value";
10743         sv = res;
10744         goto report;
10745     }
10746
10747     return res;
10748 }
10749
10750 /* Returns a NUL terminated string, with the length of the string written to
10751    *slp
10752    */
10753 STATIC char *
10754 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10755 {
10756     dVAR;
10757     register char *d = dest;
10758     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10759
10760     PERL_ARGS_ASSERT_SCAN_WORD;
10761
10762     for (;;) {
10763         if (d >= e)
10764             Perl_croak(aTHX_ ident_too_long);
10765         if (isALNUM(*s))        /* UTF handled below */
10766             *d++ = *s++;
10767         else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10768             *d++ = ':';
10769             *d++ = ':';
10770             s++;
10771         }
10772         else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10773             *d++ = *s++;
10774             *d++ = *s++;
10775         }
10776         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10777             char *t = s + UTF8SKIP(s);
10778             size_t len;
10779             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10780                 t += UTF8SKIP(t);
10781             len = t - s;
10782             if (d + len > e)
10783                 Perl_croak(aTHX_ ident_too_long);
10784             Copy(s, d, len, char);
10785             d += len;
10786             s = t;
10787         }
10788         else {
10789             *d = '\0';
10790             *slp = d - dest;
10791             return s;
10792         }
10793     }
10794 }
10795
10796 STATIC char *
10797 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10798 {
10799     dVAR;
10800     char *bracket = NULL;
10801     char funny = *s++;
10802     register char *d = dest;
10803     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10804
10805     PERL_ARGS_ASSERT_SCAN_IDENT;
10806
10807     if (isSPACE(*s))
10808         s = PEEKSPACE(s);
10809     if (isDIGIT(*s)) {
10810         while (isDIGIT(*s)) {
10811             if (d >= e)
10812                 Perl_croak(aTHX_ ident_too_long);
10813             *d++ = *s++;
10814         }
10815     }
10816     else {
10817         for (;;) {
10818             if (d >= e)
10819                 Perl_croak(aTHX_ ident_too_long);
10820             if (isALNUM(*s))    /* UTF handled below */
10821                 *d++ = *s++;
10822             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10823                 *d++ = ':';
10824                 *d++ = ':';
10825                 s++;
10826             }
10827             else if (*s == ':' && s[1] == ':') {
10828                 *d++ = *s++;
10829                 *d++ = *s++;
10830             }
10831             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10832                 char *t = s + UTF8SKIP(s);
10833                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10834                     t += UTF8SKIP(t);
10835                 if (d + (t - s) > e)
10836                     Perl_croak(aTHX_ ident_too_long);
10837                 Copy(s, d, t - s, char);
10838                 d += t - s;
10839                 s = t;
10840             }
10841             else
10842                 break;
10843         }
10844     }
10845     *d = '\0';
10846     d = dest;
10847     if (*d) {
10848         if (PL_lex_state != LEX_NORMAL)
10849             PL_lex_state = LEX_INTERPENDMAYBE;
10850         return s;
10851     }
10852     if (*s == '$' && s[1] &&
10853         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10854     {
10855         return s;
10856     }
10857     if (*s == '{') {
10858         bracket = s;
10859         s++;
10860     }
10861     else if (ck_uni)
10862         check_uni();
10863     if (s < send)
10864         *d = *s++;
10865     d[1] = '\0';
10866     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10867         *d = toCTRL(*s);
10868         s++;
10869     }
10870     if (bracket) {
10871         if (isSPACE(s[-1])) {
10872             while (s < send) {
10873                 const char ch = *s++;
10874                 if (!SPACE_OR_TAB(ch)) {
10875                     *d = ch;
10876                     break;
10877                 }
10878             }
10879         }
10880         if (isIDFIRST_lazy_if(d,UTF)) {
10881             d++;
10882             if (UTF) {
10883                 char *end = s;
10884                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10885                     end += UTF8SKIP(end);
10886                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10887                         end += UTF8SKIP(end);
10888                 }
10889                 Copy(s, d, end - s, char);
10890                 d += end - s;
10891                 s = end;
10892             }
10893             else {
10894                 while ((isALNUM(*s) || *s == ':') && d < e)
10895                     *d++ = *s++;
10896                 if (d >= e)
10897                     Perl_croak(aTHX_ ident_too_long);
10898             }
10899             *d = '\0';
10900             while (s < send && SPACE_OR_TAB(*s))
10901                 s++;
10902             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10903                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10904                     const char * const brack =
10905                         (const char *)
10906                         ((*s == '[') ? "[...]" : "{...}");
10907                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10908                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10909                         funny, dest, brack, funny, dest, brack);
10910                 }
10911                 bracket++;
10912                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10913                 return s;
10914             }
10915         }
10916         /* Handle extended ${^Foo} variables
10917          * 1999-02-27 mjd-perl-patch@plover.com */
10918         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10919                  && isALNUM(*s))
10920         {
10921             d++;
10922             while (isALNUM(*s) && d < e) {
10923                 *d++ = *s++;
10924             }
10925             if (d >= e)
10926                 Perl_croak(aTHX_ ident_too_long);
10927             *d = '\0';
10928         }
10929         if (*s == '}') {
10930             s++;
10931             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10932                 PL_lex_state = LEX_INTERPEND;
10933                 PL_expect = XREF;
10934             }
10935             if (PL_lex_state == LEX_NORMAL) {
10936                 if (ckWARN(WARN_AMBIGUOUS) &&
10937                     (keyword(dest, d - dest, 0)
10938                      || get_cvn_flags(dest, d - dest, 0)))
10939                 {
10940                     if (funny == '#')
10941                         funny = '@';
10942                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10943                         "Ambiguous use of %c{%s} resolved to %c%s",
10944                         funny, dest, funny, dest);
10945                 }
10946             }
10947         }
10948         else {
10949             s = bracket;                /* let the parser handle it */
10950             *dest = '\0';
10951         }
10952     }
10953     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10954         PL_lex_state = LEX_INTERPEND;
10955     return s;
10956 }
10957
10958 void
10959 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10960 {
10961     PERL_ARGS_ASSERT_PMFLAG;
10962
10963     PERL_UNUSED_CONTEXT;
10964     if (ch<256) {
10965         const char c = (char)ch;
10966         switch (c) {
10967             CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10968             case GLOBAL_PAT_MOD:    *pmfl |= PMf_GLOBAL; break;
10969             case CONTINUE_PAT_MOD:  *pmfl |= PMf_CONTINUE; break;
10970             case ONCE_PAT_MOD:      *pmfl |= PMf_KEEP; break;
10971             case KEEPCOPY_PAT_MOD:  *pmfl |= PMf_KEEPCOPY; break;
10972         }
10973     }
10974 }
10975
10976 STATIC char *
10977 S_scan_pat(pTHX_ char *start, I32 type)
10978 {
10979     dVAR;
10980     PMOP *pm;
10981     char *s = scan_str(start,!!PL_madskills,FALSE);
10982     const char * const valid_flags =
10983         (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10984 #ifdef PERL_MAD
10985     char *modstart;
10986 #endif
10987
10988     PERL_ARGS_ASSERT_SCAN_PAT;
10989
10990     if (!s) {
10991         const char * const delimiter = skipspace(start);
10992         Perl_croak(aTHX_
10993                    (const char *)
10994                    (*delimiter == '?'
10995                     ? "Search pattern not terminated or ternary operator parsed as search pattern"
10996                     : "Search pattern not terminated" ));
10997     }
10998
10999     pm = (PMOP*)newPMOP(type, 0);
11000     if (PL_multi_open == '?') {
11001         /* This is the only point in the code that sets PMf_ONCE:  */
11002         pm->op_pmflags |= PMf_ONCE;
11003
11004         /* Hence it's safe to do this bit of PMOP book-keeping here, which
11005            allows us to restrict the list needed by reset to just the ??
11006            matches.  */
11007         assert(type != OP_TRANS);
11008         if (PL_curstash) {
11009             MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11010             U32 elements;
11011             if (!mg) {
11012                 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11013                                  0);
11014             }
11015             elements = mg->mg_len / sizeof(PMOP**);
11016             Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11017             ((PMOP**)mg->mg_ptr) [elements++] = pm;
11018             mg->mg_len = elements * sizeof(PMOP**);
11019             PmopSTASH_set(pm,PL_curstash);
11020         }
11021     }
11022 #ifdef PERL_MAD
11023     modstart = s;
11024 #endif
11025     while (*s && strchr(valid_flags, *s))
11026         pmflag(&pm->op_pmflags,*s++);
11027 #ifdef PERL_MAD
11028     if (PL_madskills && modstart != s) {
11029         SV* tmptoken = newSVpvn(modstart, s - modstart);
11030         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11031     }
11032 #endif
11033     /* issue a warning if /c is specified,but /g is not */
11034     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
11035             && ckWARN(WARN_REGEXP))
11036     {
11037         Perl_warner(aTHX_ packWARN(WARN_REGEXP),
11038             "Use of /c modifier is meaningless without /g" );
11039     }
11040
11041     PL_lex_op = (OP*)pm;
11042     pl_yylval.ival = OP_MATCH;
11043     return s;
11044 }
11045
11046 STATIC char *
11047 S_scan_subst(pTHX_ char *start)
11048 {
11049     dVAR;
11050     register char *s;
11051     register PMOP *pm;
11052     I32 first_start;
11053     I32 es = 0;
11054 #ifdef PERL_MAD
11055     char *modstart;
11056 #endif
11057
11058     PERL_ARGS_ASSERT_SCAN_SUBST;
11059
11060     pl_yylval.ival = OP_NULL;
11061
11062     s = scan_str(start,!!PL_madskills,FALSE);
11063
11064     if (!s)
11065         Perl_croak(aTHX_ "Substitution pattern not terminated");
11066
11067     if (s[-1] == PL_multi_open)
11068         s--;
11069 #ifdef PERL_MAD
11070     if (PL_madskills) {
11071         CURMAD('q', PL_thisopen);
11072         CURMAD('_', PL_thiswhite);
11073         CURMAD('E', PL_thisstuff);
11074         CURMAD('Q', PL_thisclose);
11075         PL_realtokenstart = s - SvPVX(PL_linestr);
11076     }
11077 #endif
11078
11079     first_start = PL_multi_start;
11080     s = scan_str(s,!!PL_madskills,FALSE);
11081     if (!s) {
11082         if (PL_lex_stuff) {
11083             SvREFCNT_dec(PL_lex_stuff);
11084             PL_lex_stuff = NULL;
11085         }
11086         Perl_croak(aTHX_ "Substitution replacement not terminated");
11087     }
11088     PL_multi_start = first_start;       /* so whole substitution is taken together */
11089
11090     pm = (PMOP*)newPMOP(OP_SUBST, 0);
11091
11092 #ifdef PERL_MAD
11093     if (PL_madskills) {
11094         CURMAD('z', PL_thisopen);
11095         CURMAD('R', PL_thisstuff);
11096         CURMAD('Z', PL_thisclose);
11097     }
11098     modstart = s;
11099 #endif
11100
11101     while (*s) {
11102         if (*s == EXEC_PAT_MOD) {
11103             s++;
11104             es++;
11105         }
11106         else if (strchr(S_PAT_MODS, *s))
11107             pmflag(&pm->op_pmflags,*s++);
11108         else
11109             break;
11110     }
11111
11112 #ifdef PERL_MAD
11113     if (PL_madskills) {
11114         if (modstart != s)
11115             curmad('m', newSVpvn(modstart, s - modstart));
11116         append_madprops(PL_thismad, (OP*)pm, 0);
11117         PL_thismad = 0;
11118     }
11119 #endif
11120     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
11121         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11122     }
11123
11124     if (es) {
11125         SV * const repl = newSVpvs("");
11126
11127         PL_sublex_info.super_bufptr = s;
11128         PL_sublex_info.super_bufend = PL_bufend;
11129         PL_multi_end = 0;
11130         pm->op_pmflags |= PMf_EVAL;
11131         while (es-- > 0) {
11132             if (es)
11133                 sv_catpvs(repl, "eval ");
11134             else
11135                 sv_catpvs(repl, "do ");
11136         }
11137         sv_catpvs(repl, "{");
11138         sv_catsv(repl, PL_lex_repl);
11139         if (strchr(SvPVX(PL_lex_repl), '#'))
11140             sv_catpvs(repl, "\n");
11141         sv_catpvs(repl, "}");
11142         SvEVALED_on(repl);
11143         SvREFCNT_dec(PL_lex_repl);
11144         PL_lex_repl = repl;
11145     }
11146
11147     PL_lex_op = (OP*)pm;
11148     pl_yylval.ival = OP_SUBST;
11149     return s;
11150 }
11151
11152 STATIC char *
11153 S_scan_trans(pTHX_ char *start)
11154 {
11155     dVAR;
11156     register char* s;
11157     OP *o;
11158     short *tbl;
11159     U8 squash;
11160     U8 del;
11161     U8 complement;
11162 #ifdef PERL_MAD
11163     char *modstart;
11164 #endif
11165
11166     PERL_ARGS_ASSERT_SCAN_TRANS;
11167
11168     pl_yylval.ival = OP_NULL;
11169
11170     s = scan_str(start,!!PL_madskills,FALSE);
11171     if (!s)
11172         Perl_croak(aTHX_ "Transliteration pattern not terminated");
11173
11174     if (s[-1] == PL_multi_open)
11175         s--;
11176 #ifdef PERL_MAD
11177     if (PL_madskills) {
11178         CURMAD('q', PL_thisopen);
11179         CURMAD('_', PL_thiswhite);
11180         CURMAD('E', PL_thisstuff);
11181         CURMAD('Q', PL_thisclose);
11182         PL_realtokenstart = s - SvPVX(PL_linestr);
11183     }
11184 #endif
11185
11186     s = scan_str(s,!!PL_madskills,FALSE);
11187     if (!s) {
11188         if (PL_lex_stuff) {
11189             SvREFCNT_dec(PL_lex_stuff);
11190             PL_lex_stuff = NULL;
11191         }
11192         Perl_croak(aTHX_ "Transliteration replacement not terminated");
11193     }
11194     if (PL_madskills) {
11195         CURMAD('z', PL_thisopen);
11196         CURMAD('R', PL_thisstuff);
11197         CURMAD('Z', PL_thisclose);
11198     }
11199
11200     complement = del = squash = 0;
11201 #ifdef PERL_MAD
11202     modstart = s;
11203 #endif
11204     while (1) {
11205         switch (*s) {
11206         case 'c':
11207             complement = OPpTRANS_COMPLEMENT;
11208             break;
11209         case 'd':
11210             del = OPpTRANS_DELETE;
11211             break;
11212         case 's':
11213             squash = OPpTRANS_SQUASH;
11214             break;
11215         default:
11216             goto no_more;
11217         }
11218         s++;
11219     }
11220   no_more:
11221
11222     tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11223     o = newPVOP(OP_TRANS, 0, (char*)tbl);
11224     o->op_private &= ~OPpTRANS_ALL;
11225     o->op_private |= del|squash|complement|
11226       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11227       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
11228
11229     PL_lex_op = o;
11230     pl_yylval.ival = OP_TRANS;
11231
11232 #ifdef PERL_MAD
11233     if (PL_madskills) {
11234         if (modstart != s)
11235             curmad('m', newSVpvn(modstart, s - modstart));
11236         append_madprops(PL_thismad, o, 0);
11237         PL_thismad = 0;
11238     }
11239 #endif
11240
11241     return s;
11242 }
11243
11244 STATIC char *
11245 S_scan_heredoc(pTHX_ register char *s)
11246 {
11247     dVAR;
11248     SV *herewas;
11249     I32 op_type = OP_SCALAR;
11250     I32 len;
11251     SV *tmpstr;
11252     char term;
11253     const char *found_newline;
11254     register char *d;
11255     register char *e;
11256     char *peek;
11257     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11258 #ifdef PERL_MAD
11259     I32 stuffstart = s - SvPVX(PL_linestr);
11260     char *tstart;
11261
11262     PL_realtokenstart = -1;
11263 #endif
11264
11265     PERL_ARGS_ASSERT_SCAN_HEREDOC;
11266
11267     s += 2;
11268     d = PL_tokenbuf;
11269     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11270     if (!outer)
11271         *d++ = '\n';
11272     peek = s;
11273     while (SPACE_OR_TAB(*peek))
11274         peek++;
11275     if (*peek == '`' || *peek == '\'' || *peek =='"') {
11276         s = peek;
11277         term = *s++;
11278         s = delimcpy(d, e, s, PL_bufend, term, &len);
11279         d += len;
11280         if (s < PL_bufend)
11281             s++;
11282     }
11283     else {
11284         if (*s == '\\')
11285             s++, term = '\'';
11286         else
11287             term = '"';
11288         if (!isALNUM_lazy_if(s,UTF))
11289             deprecate_old("bare << to mean <<\"\"");
11290         for (; isALNUM_lazy_if(s,UTF); s++) {
11291             if (d < e)
11292                 *d++ = *s;
11293         }
11294     }
11295     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11296         Perl_croak(aTHX_ "Delimiter for here document is too long");
11297     *d++ = '\n';
11298     *d = '\0';
11299     len = d - PL_tokenbuf;
11300
11301 #ifdef PERL_MAD
11302     if (PL_madskills) {
11303         tstart = PL_tokenbuf + !outer;
11304         PL_thisclose = newSVpvn(tstart, len - !outer);
11305         tstart = SvPVX(PL_linestr) + stuffstart;
11306         PL_thisopen = newSVpvn(tstart, s - tstart);
11307         stuffstart = s - SvPVX(PL_linestr);
11308     }
11309 #endif
11310 #ifndef PERL_STRICT_CR
11311     d = strchr(s, '\r');
11312     if (d) {
11313         char * const olds = s;
11314         s = d;
11315         while (s < PL_bufend) {
11316             if (*s == '\r') {
11317                 *d++ = '\n';
11318                 if (*++s == '\n')
11319                     s++;
11320             }
11321             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
11322                 *d++ = *s++;
11323                 s++;
11324             }
11325             else
11326                 *d++ = *s++;
11327         }
11328         *d = '\0';
11329         PL_bufend = d;
11330         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11331         s = olds;
11332     }
11333 #endif
11334 #ifdef PERL_MAD
11335     found_newline = 0;
11336 #endif
11337     if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11338         herewas = newSVpvn(s,PL_bufend-s);
11339     }
11340     else {
11341 #ifdef PERL_MAD
11342         herewas = newSVpvn(s-1,found_newline-s+1);
11343 #else
11344         s--;
11345         herewas = newSVpvn(s,found_newline-s);
11346 #endif
11347     }
11348 #ifdef PERL_MAD
11349     if (PL_madskills) {
11350         tstart = SvPVX(PL_linestr) + stuffstart;
11351         if (PL_thisstuff)
11352             sv_catpvn(PL_thisstuff, tstart, s - tstart);
11353         else
11354             PL_thisstuff = newSVpvn(tstart, s - tstart);
11355     }
11356 #endif
11357     s += SvCUR(herewas);
11358
11359 #ifdef PERL_MAD
11360     stuffstart = s - SvPVX(PL_linestr);
11361
11362     if (found_newline)
11363         s--;
11364 #endif
11365
11366     tmpstr = newSV_type(SVt_PVIV);
11367     SvGROW(tmpstr, 80);
11368     if (term == '\'') {
11369         op_type = OP_CONST;
11370         SvIV_set(tmpstr, -1);
11371     }
11372     else if (term == '`') {
11373         op_type = OP_BACKTICK;
11374         SvIV_set(tmpstr, '\\');
11375     }
11376
11377     CLINE;
11378     PL_multi_start = CopLINE(PL_curcop);
11379     PL_multi_open = PL_multi_close = '<';
11380     term = *PL_tokenbuf;
11381     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11382         char * const bufptr = PL_sublex_info.super_bufptr;
11383         char * const bufend = PL_sublex_info.super_bufend;
11384         char * const olds = s - SvCUR(herewas);
11385         s = strchr(bufptr, '\n');
11386         if (!s)
11387             s = bufend;
11388         d = s;
11389         while (s < bufend &&
11390           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11391             if (*s++ == '\n')
11392                 CopLINE_inc(PL_curcop);
11393         }
11394         if (s >= bufend) {
11395             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11396             missingterm(PL_tokenbuf);
11397         }
11398         sv_setpvn(herewas,bufptr,d-bufptr+1);
11399         sv_setpvn(tmpstr,d+1,s-d);
11400         s += len - 1;
11401         sv_catpvn(herewas,s,bufend-s);
11402         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11403
11404         s = olds;
11405         goto retval;
11406     }
11407     else if (!outer) {
11408         d = s;
11409         while (s < PL_bufend &&
11410           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11411             if (*s++ == '\n')
11412                 CopLINE_inc(PL_curcop);
11413         }
11414         if (s >= PL_bufend) {
11415             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11416             missingterm(PL_tokenbuf);
11417         }
11418         sv_setpvn(tmpstr,d+1,s-d);
11419 #ifdef PERL_MAD
11420         if (PL_madskills) {
11421             if (PL_thisstuff)
11422                 sv_catpvn(PL_thisstuff, d + 1, s - d);
11423             else
11424                 PL_thisstuff = newSVpvn(d + 1, s - d);
11425             stuffstart = s - SvPVX(PL_linestr);
11426         }
11427 #endif
11428         s += len - 1;
11429         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11430
11431         sv_catpvn(herewas,s,PL_bufend-s);
11432         sv_setsv(PL_linestr,herewas);
11433         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11434         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11435         PL_last_lop = PL_last_uni = NULL;
11436     }
11437     else
11438         sv_setpvs(tmpstr,"");   /* avoid "uninitialized" warning */
11439     while (s >= PL_bufend) {    /* multiple line string? */
11440 #ifdef PERL_MAD
11441         if (PL_madskills) {
11442             tstart = SvPVX(PL_linestr) + stuffstart;
11443             if (PL_thisstuff)
11444                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11445             else
11446                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11447         }
11448 #endif
11449         if (!outer ||
11450          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11451             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11452             missingterm(PL_tokenbuf);
11453         }
11454 #ifdef PERL_MAD
11455         stuffstart = s - SvPVX(PL_linestr);
11456 #endif
11457         CopLINE_inc(PL_curcop);
11458         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11459         PL_last_lop = PL_last_uni = NULL;
11460 #ifndef PERL_STRICT_CR
11461         if (PL_bufend - PL_linestart >= 2) {
11462             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11463                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11464             {
11465                 PL_bufend[-2] = '\n';
11466                 PL_bufend--;
11467                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11468             }
11469             else if (PL_bufend[-1] == '\r')
11470                 PL_bufend[-1] = '\n';
11471         }
11472         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11473             PL_bufend[-1] = '\n';
11474 #endif
11475         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11476             update_debugger_info(PL_linestr, NULL, 0);
11477         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11478             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11479             *(SvPVX(PL_linestr) + off ) = ' ';
11480             sv_catsv(PL_linestr,herewas);
11481             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11482             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11483         }
11484         else {
11485             s = PL_bufend;
11486             sv_catsv(tmpstr,PL_linestr);
11487         }
11488     }
11489     s++;
11490 retval:
11491     PL_multi_end = CopLINE(PL_curcop);
11492     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11493         SvPV_shrink_to_cur(tmpstr);
11494     }
11495     SvREFCNT_dec(herewas);
11496     if (!IN_BYTES) {
11497         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11498             SvUTF8_on(tmpstr);
11499         else if (PL_encoding)
11500             sv_recode_to_utf8(tmpstr, PL_encoding);
11501     }
11502     PL_lex_stuff = tmpstr;
11503     pl_yylval.ival = op_type;
11504     return s;
11505 }
11506
11507 /* scan_inputsymbol
11508    takes: current position in input buffer
11509    returns: new position in input buffer
11510    side-effects: pl_yylval and lex_op are set.
11511
11512    This code handles:
11513
11514    <>           read from ARGV
11515    <FH>         read from filehandle
11516    <pkg::FH>    read from package qualified filehandle
11517    <pkg'FH>     read from package qualified filehandle
11518    <$fh>        read from filehandle in $fh
11519    <*.h>        filename glob
11520
11521 */
11522
11523 STATIC char *
11524 S_scan_inputsymbol(pTHX_ char *start)
11525 {
11526     dVAR;
11527     register char *s = start;           /* current position in buffer */
11528     char *end;
11529     I32 len;
11530     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11531     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11532
11533     PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11534
11535     end = strchr(s, '\n');
11536     if (!end)
11537         end = PL_bufend;
11538     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11539
11540     /* die if we didn't have space for the contents of the <>,
11541        or if it didn't end, or if we see a newline
11542     */
11543
11544     if (len >= (I32)sizeof PL_tokenbuf)
11545         Perl_croak(aTHX_ "Excessively long <> operator");
11546     if (s >= end)
11547         Perl_croak(aTHX_ "Unterminated <> operator");
11548
11549     s++;
11550
11551     /* check for <$fh>
11552        Remember, only scalar variables are interpreted as filehandles by
11553        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11554        treated as a glob() call.
11555        This code makes use of the fact that except for the $ at the front,
11556        a scalar variable and a filehandle look the same.
11557     */
11558     if (*d == '$' && d[1]) d++;
11559
11560     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11561     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11562         d++;
11563
11564     /* If we've tried to read what we allow filehandles to look like, and
11565        there's still text left, then it must be a glob() and not a getline.
11566        Use scan_str to pull out the stuff between the <> and treat it
11567        as nothing more than a string.
11568     */
11569
11570     if (d - PL_tokenbuf != len) {
11571         pl_yylval.ival = OP_GLOB;
11572         s = scan_str(start,!!PL_madskills,FALSE);
11573         if (!s)
11574            Perl_croak(aTHX_ "Glob not terminated");
11575         return s;
11576     }
11577     else {
11578         bool readline_overriden = FALSE;
11579         GV *gv_readline;
11580         GV **gvp;
11581         /* we're in a filehandle read situation */
11582         d = PL_tokenbuf;
11583
11584         /* turn <> into <ARGV> */
11585         if (!len)
11586             Copy("ARGV",d,5,char);
11587
11588         /* Check whether readline() is overriden */
11589         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11590         if ((gv_readline
11591                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11592                 ||
11593                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11594                  && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11595                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11596             readline_overriden = TRUE;
11597
11598         /* if <$fh>, create the ops to turn the variable into a
11599            filehandle
11600         */
11601         if (*d == '$') {
11602             /* try to find it in the pad for this block, otherwise find
11603                add symbol table ops
11604             */
11605             const PADOFFSET tmp = pad_findmy(d);
11606             if (tmp != NOT_IN_PAD) {
11607                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11608                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11609                     HEK * const stashname = HvNAME_HEK(stash);
11610                     SV * const sym = sv_2mortal(newSVhek(stashname));
11611                     sv_catpvs(sym, "::");
11612                     sv_catpv(sym, d+1);
11613                     d = SvPVX(sym);
11614                     goto intro_sym;
11615                 }
11616                 else {
11617                     OP * const o = newOP(OP_PADSV, 0);
11618                     o->op_targ = tmp;
11619                     PL_lex_op = readline_overriden
11620                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11621                                 append_elem(OP_LIST, o,
11622                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11623                         : (OP*)newUNOP(OP_READLINE, 0, o);
11624                 }
11625             }
11626             else {
11627                 GV *gv;
11628                 ++d;
11629 intro_sym:
11630                 gv = gv_fetchpv(d,
11631                                 (PL_in_eval
11632                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11633                                  : GV_ADDMULTI),
11634                                 SVt_PV);
11635                 PL_lex_op = readline_overriden
11636                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11637                             append_elem(OP_LIST,
11638                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11639                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11640                     : (OP*)newUNOP(OP_READLINE, 0,
11641                             newUNOP(OP_RV2SV, 0,
11642                                 newGVOP(OP_GV, 0, gv)));
11643             }
11644             if (!readline_overriden)
11645                 PL_lex_op->op_flags |= OPf_SPECIAL;
11646             /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11647             pl_yylval.ival = OP_NULL;
11648         }
11649
11650         /* If it's none of the above, it must be a literal filehandle
11651            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11652         else {
11653             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11654             PL_lex_op = readline_overriden
11655                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11656                         append_elem(OP_LIST,
11657                             newGVOP(OP_GV, 0, gv),
11658                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11659                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11660             pl_yylval.ival = OP_NULL;
11661         }
11662     }
11663
11664     return s;
11665 }
11666
11667
11668 /* scan_str
11669    takes: start position in buffer
11670           keep_quoted preserve \ on the embedded delimiter(s)
11671           keep_delims preserve the delimiters around the string
11672    returns: position to continue reading from buffer
11673    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11674         updates the read buffer.
11675
11676    This subroutine pulls a string out of the input.  It is called for:
11677         q               single quotes           q(literal text)
11678         '               single quotes           'literal text'
11679         qq              double quotes           qq(interpolate $here please)
11680         "               double quotes           "interpolate $here please"
11681         qx              backticks               qx(/bin/ls -l)
11682         `               backticks               `/bin/ls -l`
11683         qw              quote words             @EXPORT_OK = qw( func() $spam )
11684         m//             regexp match            m/this/
11685         s///            regexp substitute       s/this/that/
11686         tr///           string transliterate    tr/this/that/
11687         y///            string transliterate    y/this/that/
11688         ($*@)           sub prototypes          sub foo ($)
11689         (stuff)         sub attr parameters     sub foo : attr(stuff)
11690         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11691
11692    In most of these cases (all but <>, patterns and transliterate)
11693    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11694    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11695    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11696    calls scan_str().
11697
11698    It skips whitespace before the string starts, and treats the first
11699    character as the delimiter.  If the delimiter is one of ([{< then
11700    the corresponding "close" character )]}> is used as the closing
11701    delimiter.  It allows quoting of delimiters, and if the string has
11702    balanced delimiters ([{<>}]) it allows nesting.
11703
11704    On success, the SV with the resulting string is put into lex_stuff or,
11705    if that is already non-NULL, into lex_repl. The second case occurs only
11706    when parsing the RHS of the special constructs s/// and tr/// (y///).
11707    For convenience, the terminating delimiter character is stuffed into
11708    SvIVX of the SV.
11709 */
11710
11711 STATIC char *
11712 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11713 {
11714     dVAR;
11715     SV *sv;                             /* scalar value: string */
11716     const char *tmps;                   /* temp string, used for delimiter matching */
11717     register char *s = start;           /* current position in the buffer */
11718     register char term;                 /* terminating character */
11719     register char *to;                  /* current position in the sv's data */
11720     I32 brackets = 1;                   /* bracket nesting level */
11721     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11722     I32 termcode;                       /* terminating char. code */
11723     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11724     STRLEN termlen;                     /* length of terminating string */
11725     int last_off = 0;                   /* last position for nesting bracket */
11726 #ifdef PERL_MAD
11727     int stuffstart;
11728     char *tstart;
11729 #endif
11730
11731     PERL_ARGS_ASSERT_SCAN_STR;
11732
11733     /* skip space before the delimiter */
11734     if (isSPACE(*s)) {
11735         s = PEEKSPACE(s);
11736     }
11737
11738 #ifdef PERL_MAD
11739     if (PL_realtokenstart >= 0) {
11740         stuffstart = PL_realtokenstart;
11741         PL_realtokenstart = -1;
11742     }
11743     else
11744         stuffstart = start - SvPVX(PL_linestr);
11745 #endif
11746     /* mark where we are, in case we need to report errors */
11747     CLINE;
11748
11749     /* after skipping whitespace, the next character is the terminator */
11750     term = *s;
11751     if (!UTF) {
11752         termcode = termstr[0] = term;
11753         termlen = 1;
11754     }
11755     else {
11756         termcode = utf8_to_uvchr((U8*)s, &termlen);
11757         Copy(s, termstr, termlen, U8);
11758         if (!UTF8_IS_INVARIANT(term))
11759             has_utf8 = TRUE;
11760     }
11761
11762     /* mark where we are */
11763     PL_multi_start = CopLINE(PL_curcop);
11764     PL_multi_open = term;
11765
11766     /* find corresponding closing delimiter */
11767     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11768         termcode = termstr[0] = term = tmps[5];
11769
11770     PL_multi_close = term;
11771
11772     /* create a new SV to hold the contents.  79 is the SV's initial length.
11773        What a random number. */
11774     sv = newSV_type(SVt_PVIV);
11775     SvGROW(sv, 80);
11776     SvIV_set(sv, termcode);
11777     (void)SvPOK_only(sv);               /* validate pointer */
11778
11779     /* move past delimiter and try to read a complete string */
11780     if (keep_delims)
11781         sv_catpvn(sv, s, termlen);
11782     s += termlen;
11783 #ifdef PERL_MAD
11784     tstart = SvPVX(PL_linestr) + stuffstart;
11785     if (!PL_thisopen && !keep_delims) {
11786         PL_thisopen = newSVpvn(tstart, s - tstart);
11787         stuffstart = s - SvPVX(PL_linestr);
11788     }
11789 #endif
11790     for (;;) {
11791         if (PL_encoding && !UTF) {
11792             bool cont = TRUE;
11793
11794             while (cont) {
11795                 int offset = s - SvPVX_const(PL_linestr);
11796                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11797                                            &offset, (char*)termstr, termlen);
11798                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11799                 char * const svlast = SvEND(sv) - 1;
11800
11801                 for (; s < ns; s++) {
11802                     if (*s == '\n' && !PL_rsfp)
11803                         CopLINE_inc(PL_curcop);
11804                 }
11805                 if (!found)
11806                     goto read_more_line;
11807                 else {
11808                     /* handle quoted delimiters */
11809                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11810                         const char *t;
11811                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11812                             t--;
11813                         if ((svlast-1 - t) % 2) {
11814                             if (!keep_quoted) {
11815                                 *(svlast-1) = term;
11816                                 *svlast = '\0';
11817                                 SvCUR_set(sv, SvCUR(sv) - 1);
11818                             }
11819                             continue;
11820                         }
11821                     }
11822                     if (PL_multi_open == PL_multi_close) {
11823                         cont = FALSE;
11824                     }
11825                     else {
11826                         const char *t;
11827                         char *w;
11828                         for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11829                             /* At here, all closes are "was quoted" one,
11830                                so we don't check PL_multi_close. */
11831                             if (*t == '\\') {
11832                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11833                                     t++;
11834                                 else
11835                                     *w++ = *t++;
11836                             }
11837                             else if (*t == PL_multi_open)
11838                                 brackets++;
11839
11840                             *w = *t;
11841                         }
11842                         if (w < t) {
11843                             *w++ = term;
11844                             *w = '\0';
11845                             SvCUR_set(sv, w - SvPVX_const(sv));
11846                         }
11847                         last_off = w - SvPVX(sv);
11848                         if (--brackets <= 0)
11849                             cont = FALSE;
11850                     }
11851                 }
11852             }
11853             if (!keep_delims) {
11854                 SvCUR_set(sv, SvCUR(sv) - 1);
11855                 *SvEND(sv) = '\0';
11856             }
11857             break;
11858         }
11859
11860         /* extend sv if need be */
11861         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11862         /* set 'to' to the next character in the sv's string */
11863         to = SvPVX(sv)+SvCUR(sv);
11864
11865         /* if open delimiter is the close delimiter read unbridle */
11866         if (PL_multi_open == PL_multi_close) {
11867             for (; s < PL_bufend; s++,to++) {
11868                 /* embedded newlines increment the current line number */
11869                 if (*s == '\n' && !PL_rsfp)
11870                     CopLINE_inc(PL_curcop);
11871                 /* handle quoted delimiters */
11872                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11873                     if (!keep_quoted && s[1] == term)
11874                         s++;
11875                 /* any other quotes are simply copied straight through */
11876                     else
11877                         *to++ = *s++;
11878                 }
11879                 /* terminate when run out of buffer (the for() condition), or
11880                    have found the terminator */
11881                 else if (*s == term) {
11882                     if (termlen == 1)
11883                         break;
11884                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11885                         break;
11886                 }
11887                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11888                     has_utf8 = TRUE;
11889                 *to = *s;
11890             }
11891         }
11892
11893         /* if the terminator isn't the same as the start character (e.g.,
11894            matched brackets), we have to allow more in the quoting, and
11895            be prepared for nested brackets.
11896         */
11897         else {
11898             /* read until we run out of string, or we find the terminator */
11899             for (; s < PL_bufend; s++,to++) {
11900                 /* embedded newlines increment the line count */
11901                 if (*s == '\n' && !PL_rsfp)
11902                     CopLINE_inc(PL_curcop);
11903                 /* backslashes can escape the open or closing characters */
11904                 if (*s == '\\' && s+1 < PL_bufend) {
11905                     if (!keep_quoted &&
11906                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11907                         s++;
11908                     else
11909                         *to++ = *s++;
11910                 }
11911                 /* allow nested opens and closes */
11912                 else if (*s == PL_multi_close && --brackets <= 0)
11913                     break;
11914                 else if (*s == PL_multi_open)
11915                     brackets++;
11916                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11917                     has_utf8 = TRUE;
11918                 *to = *s;
11919             }
11920         }
11921         /* terminate the copied string and update the sv's end-of-string */
11922         *to = '\0';
11923         SvCUR_set(sv, to - SvPVX_const(sv));
11924
11925         /*
11926          * this next chunk reads more into the buffer if we're not done yet
11927          */
11928
11929         if (s < PL_bufend)
11930             break;              /* handle case where we are done yet :-) */
11931
11932 #ifndef PERL_STRICT_CR
11933         if (to - SvPVX_const(sv) >= 2) {
11934             if ((to[-2] == '\r' && to[-1] == '\n') ||
11935                 (to[-2] == '\n' && to[-1] == '\r'))
11936             {
11937                 to[-2] = '\n';
11938                 to--;
11939                 SvCUR_set(sv, to - SvPVX_const(sv));
11940             }
11941             else if (to[-1] == '\r')
11942                 to[-1] = '\n';
11943         }
11944         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11945             to[-1] = '\n';
11946 #endif
11947
11948      read_more_line:
11949         /* if we're out of file, or a read fails, bail and reset the current
11950            line marker so we can report where the unterminated string began
11951         */
11952 #ifdef PERL_MAD
11953         if (PL_madskills) {
11954             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11955             if (PL_thisstuff)
11956                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11957             else
11958                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11959         }
11960 #endif
11961         if (!PL_rsfp ||
11962          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11963             sv_free(sv);
11964             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11965             return NULL;
11966         }
11967 #ifdef PERL_MAD
11968         stuffstart = 0;
11969 #endif
11970         /* we read a line, so increment our line counter */
11971         CopLINE_inc(PL_curcop);
11972
11973         /* update debugger info */
11974         if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11975             update_debugger_info(PL_linestr, NULL, 0);
11976
11977         /* having changed the buffer, we must update PL_bufend */
11978         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11979         PL_last_lop = PL_last_uni = NULL;
11980     }
11981
11982     /* at this point, we have successfully read the delimited string */
11983
11984     if (!PL_encoding || UTF) {
11985 #ifdef PERL_MAD
11986         if (PL_madskills) {
11987             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11988             const int len = s - tstart;
11989             if (PL_thisstuff)
11990                 sv_catpvn(PL_thisstuff, tstart, len);
11991             else
11992                 PL_thisstuff = newSVpvn(tstart, len);
11993             if (!PL_thisclose && !keep_delims)
11994                 PL_thisclose = newSVpvn(s,termlen);
11995         }
11996 #endif
11997
11998         if (keep_delims)
11999             sv_catpvn(sv, s, termlen);
12000         s += termlen;
12001     }
12002 #ifdef PERL_MAD
12003     else {
12004         if (PL_madskills) {
12005             char * const tstart = SvPVX(PL_linestr) + stuffstart;
12006             const int len = s - tstart - termlen;
12007             if (PL_thisstuff)
12008                 sv_catpvn(PL_thisstuff, tstart, len);
12009             else
12010                 PL_thisstuff = newSVpvn(tstart, len);
12011             if (!PL_thisclose && !keep_delims)
12012                 PL_thisclose = newSVpvn(s - termlen,termlen);
12013         }
12014     }
12015 #endif
12016     if (has_utf8 || PL_encoding)
12017         SvUTF8_on(sv);
12018
12019     PL_multi_end = CopLINE(PL_curcop);
12020
12021     /* if we allocated too much space, give some back */
12022     if (SvCUR(sv) + 5 < SvLEN(sv)) {
12023         SvLEN_set(sv, SvCUR(sv) + 1);
12024         SvPV_renew(sv, SvLEN(sv));
12025     }
12026
12027     /* decide whether this is the first or second quoted string we've read
12028        for this op
12029     */
12030
12031     if (PL_lex_stuff)
12032         PL_lex_repl = sv;
12033     else
12034         PL_lex_stuff = sv;
12035     return s;
12036 }
12037
12038 /*
12039   scan_num
12040   takes: pointer to position in buffer
12041   returns: pointer to new position in buffer
12042   side-effects: builds ops for the constant in pl_yylval.op
12043
12044   Read a number in any of the formats that Perl accepts:
12045
12046   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
12047   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
12048   0b[01](_?[01])*
12049   0[0-7](_?[0-7])*
12050   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12051
12052   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12053   thing it reads.
12054
12055   If it reads a number without a decimal point or an exponent, it will
12056   try converting the number to an integer and see if it can do so
12057   without loss of precision.
12058 */
12059
12060 char *
12061 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12062 {
12063     dVAR;
12064     register const char *s = start;     /* current position in buffer */
12065     register char *d;                   /* destination in temp buffer */
12066     register char *e;                   /* end of temp buffer */
12067     NV nv;                              /* number read, as a double */
12068     SV *sv = NULL;                      /* place to put the converted number */
12069     bool floatit;                       /* boolean: int or float? */
12070     const char *lastub = NULL;          /* position of last underbar */
12071     static char const number_too_long[] = "Number too long";
12072
12073     PERL_ARGS_ASSERT_SCAN_NUM;
12074
12075     /* We use the first character to decide what type of number this is */
12076
12077     switch (*s) {
12078     default:
12079       Perl_croak(aTHX_ "panic: scan_num");
12080
12081     /* if it starts with a 0, it could be an octal number, a decimal in
12082        0.13 disguise, or a hexadecimal number, or a binary number. */
12083     case '0':
12084         {
12085           /* variables:
12086              u          holds the "number so far"
12087              shift      the power of 2 of the base
12088                         (hex == 4, octal == 3, binary == 1)
12089              overflowed was the number more than we can hold?
12090
12091              Shift is used when we add a digit.  It also serves as an "are
12092              we in octal/hex/binary?" indicator to disallow hex characters
12093              when in octal mode.
12094            */
12095             NV n = 0.0;
12096             UV u = 0;
12097             I32 shift;
12098             bool overflowed = FALSE;
12099             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
12100             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12101             static const char* const bases[5] =
12102               { "", "binary", "", "octal", "hexadecimal" };
12103             static const char* const Bases[5] =
12104               { "", "Binary", "", "Octal", "Hexadecimal" };
12105             static const char* const maxima[5] =
12106               { "",
12107                 "0b11111111111111111111111111111111",
12108                 "",
12109                 "037777777777",
12110                 "0xffffffff" };
12111             const char *base, *Base, *max;
12112
12113             /* check for hex */
12114             if (s[1] == 'x') {
12115                 shift = 4;
12116                 s += 2;
12117                 just_zero = FALSE;
12118             } else if (s[1] == 'b') {
12119                 shift = 1;
12120                 s += 2;
12121                 just_zero = FALSE;
12122             }
12123             /* check for a decimal in disguise */
12124             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12125                 goto decimal;
12126             /* so it must be octal */
12127             else {
12128                 shift = 3;
12129                 s++;
12130             }
12131
12132             if (*s == '_') {
12133                if (ckWARN(WARN_SYNTAX))
12134                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12135                                "Misplaced _ in number");
12136                lastub = s++;
12137             }
12138
12139             base = bases[shift];
12140             Base = Bases[shift];
12141             max  = maxima[shift];
12142
12143             /* read the rest of the number */
12144             for (;;) {
12145                 /* x is used in the overflow test,
12146                    b is the digit we're adding on. */
12147                 UV x, b;
12148
12149                 switch (*s) {
12150
12151                 /* if we don't mention it, we're done */
12152                 default:
12153                     goto out;
12154
12155                 /* _ are ignored -- but warned about if consecutive */
12156                 case '_':
12157                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12158                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12159                                     "Misplaced _ in number");
12160                     lastub = s++;
12161                     break;
12162
12163                 /* 8 and 9 are not octal */
12164                 case '8': case '9':
12165                     if (shift == 3)
12166                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12167                     /* FALL THROUGH */
12168
12169                 /* octal digits */
12170                 case '2': case '3': case '4':
12171                 case '5': case '6': case '7':
12172                     if (shift == 1)
12173                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12174                     /* FALL THROUGH */
12175
12176                 case '0': case '1':
12177                     b = *s++ & 15;              /* ASCII digit -> value of digit */
12178                     goto digit;
12179
12180                 /* hex digits */
12181                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12182                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12183                     /* make sure they said 0x */
12184                     if (shift != 4)
12185                         goto out;
12186                     b = (*s++ & 7) + 9;
12187
12188                     /* Prepare to put the digit we have onto the end
12189                        of the number so far.  We check for overflows.
12190                     */
12191
12192                   digit:
12193                     just_zero = FALSE;
12194                     if (!overflowed) {
12195                         x = u << shift; /* make room for the digit */
12196
12197                         if ((x >> shift) != u
12198                             && !(PL_hints & HINT_NEW_BINARY)) {
12199                             overflowed = TRUE;
12200                             n = (NV) u;
12201                             if (ckWARN_d(WARN_OVERFLOW))
12202                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12203                                             "Integer overflow in %s number",
12204                                             base);
12205                         } else
12206                             u = x | b;          /* add the digit to the end */
12207                     }
12208                     if (overflowed) {
12209                         n *= nvshift[shift];
12210                         /* If an NV has not enough bits in its
12211                          * mantissa to represent an UV this summing of
12212                          * small low-order numbers is a waste of time
12213                          * (because the NV cannot preserve the
12214                          * low-order bits anyway): we could just
12215                          * remember when did we overflow and in the
12216                          * end just multiply n by the right
12217                          * amount. */
12218                         n += (NV) b;
12219                     }
12220                     break;
12221                 }
12222             }
12223
12224           /* if we get here, we had success: make a scalar value from
12225              the number.
12226           */
12227           out:
12228
12229             /* final misplaced underbar check */
12230             if (s[-1] == '_') {
12231                 if (ckWARN(WARN_SYNTAX))
12232                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12233             }
12234
12235             sv = newSV(0);
12236             if (overflowed) {
12237                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12238                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12239                                 "%s number > %s non-portable",
12240                                 Base, max);
12241                 sv_setnv(sv, n);
12242             }
12243             else {
12244 #if UVSIZE > 4
12245                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12246                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12247                                 "%s number > %s non-portable",
12248                                 Base, max);
12249 #endif
12250                 sv_setuv(sv, u);
12251             }
12252             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12253                 sv = new_constant(start, s - start, "integer",
12254                                   sv, NULL, NULL, 0);
12255             else if (PL_hints & HINT_NEW_BINARY)
12256                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12257         }
12258         break;
12259
12260     /*
12261       handle decimal numbers.
12262       we're also sent here when we read a 0 as the first digit
12263     */
12264     case '1': case '2': case '3': case '4': case '5':
12265     case '6': case '7': case '8': case '9': case '.':
12266       decimal:
12267         d = PL_tokenbuf;
12268         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12269         floatit = FALSE;
12270
12271         /* read next group of digits and _ and copy into d */
12272         while (isDIGIT(*s) || *s == '_') {
12273             /* skip underscores, checking for misplaced ones
12274                if -w is on
12275             */
12276             if (*s == '_') {
12277                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12278                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12279                                 "Misplaced _ in number");
12280                 lastub = s++;
12281             }
12282             else {
12283                 /* check for end of fixed-length buffer */
12284                 if (d >= e)
12285                     Perl_croak(aTHX_ number_too_long);
12286                 /* if we're ok, copy the character */
12287                 *d++ = *s++;
12288             }
12289         }
12290
12291         /* final misplaced underbar check */
12292         if (lastub && s == lastub + 1) {
12293             if (ckWARN(WARN_SYNTAX))
12294                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12295         }
12296
12297         /* read a decimal portion if there is one.  avoid
12298            3..5 being interpreted as the number 3. followed
12299            by .5
12300         */
12301         if (*s == '.' && s[1] != '.') {
12302             floatit = TRUE;
12303             *d++ = *s++;
12304
12305             if (*s == '_') {
12306                 if (ckWARN(WARN_SYNTAX))
12307                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12308                                 "Misplaced _ in number");
12309                 lastub = s;
12310             }
12311
12312             /* copy, ignoring underbars, until we run out of digits.
12313             */
12314             for (; isDIGIT(*s) || *s == '_'; s++) {
12315                 /* fixed length buffer check */
12316                 if (d >= e)
12317                     Perl_croak(aTHX_ number_too_long);
12318                 if (*s == '_') {
12319                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12320                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12321                                    "Misplaced _ in number");
12322                    lastub = s;
12323                 }
12324                 else
12325                     *d++ = *s;
12326             }
12327             /* fractional part ending in underbar? */
12328             if (s[-1] == '_') {
12329                 if (ckWARN(WARN_SYNTAX))
12330                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12331                                 "Misplaced _ in number");
12332             }
12333             if (*s == '.' && isDIGIT(s[1])) {
12334                 /* oops, it's really a v-string, but without the "v" */
12335                 s = start;
12336                 goto vstring;
12337             }
12338         }
12339
12340         /* read exponent part, if present */
12341         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12342             floatit = TRUE;
12343             s++;
12344
12345             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12346             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
12347
12348             /* stray preinitial _ */
12349             if (*s == '_') {
12350                 if (ckWARN(WARN_SYNTAX))
12351                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12352                                 "Misplaced _ in number");
12353                 lastub = s++;
12354             }
12355
12356             /* allow positive or negative exponent */
12357             if (*s == '+' || *s == '-')
12358                 *d++ = *s++;
12359
12360             /* stray initial _ */
12361             if (*s == '_') {
12362                 if (ckWARN(WARN_SYNTAX))
12363                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12364                                 "Misplaced _ in number");
12365                 lastub = s++;
12366             }
12367
12368             /* read digits of exponent */
12369             while (isDIGIT(*s) || *s == '_') {
12370                 if (isDIGIT(*s)) {
12371                     if (d >= e)
12372                         Perl_croak(aTHX_ number_too_long);
12373                     *d++ = *s++;
12374                 }
12375                 else {
12376                    if (((lastub && s == lastub + 1) ||
12377                         (!isDIGIT(s[1]) && s[1] != '_'))
12378                     && ckWARN(WARN_SYNTAX))
12379                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12380                                    "Misplaced _ in number");
12381                    lastub = s++;
12382                 }
12383             }
12384         }
12385
12386
12387         /* make an sv from the string */
12388         sv = newSV(0);
12389
12390         /*
12391            We try to do an integer conversion first if no characters
12392            indicating "float" have been found.
12393          */
12394
12395         if (!floatit) {
12396             UV uv;
12397             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12398
12399             if (flags == IS_NUMBER_IN_UV) {
12400               if (uv <= IV_MAX)
12401                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12402               else
12403                 sv_setuv(sv, uv);
12404             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12405               if (uv <= (UV) IV_MIN)
12406                 sv_setiv(sv, -(IV)uv);
12407               else
12408                 floatit = TRUE;
12409             } else
12410               floatit = TRUE;
12411         }
12412         if (floatit) {
12413             /* terminate the string */
12414             *d = '\0';
12415             nv = Atof(PL_tokenbuf);
12416             sv_setnv(sv, nv);
12417         }
12418
12419         if ( floatit
12420              ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12421             const char *const key = floatit ? "float" : "integer";
12422             const STRLEN keylen = floatit ? 5 : 7;
12423             sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12424                                 key, keylen, sv, NULL, NULL, 0);
12425         }
12426         break;
12427
12428     /* if it starts with a v, it could be a v-string */
12429     case 'v':
12430 vstring:
12431                 sv = newSV(5); /* preallocate storage space */
12432                 s = scan_vstring(s, PL_bufend, sv);
12433         break;
12434     }
12435
12436     /* make the op for the constant and return */
12437
12438     if (sv)
12439         lvalp->opval = newSVOP(OP_CONST, 0, sv);
12440     else
12441         lvalp->opval = NULL;
12442
12443     return (char *)s;
12444 }
12445
12446 STATIC char *
12447 S_scan_formline(pTHX_ register char *s)
12448 {
12449     dVAR;
12450     register char *eol;
12451     register char *t;
12452     SV * const stuff = newSVpvs("");
12453     bool needargs = FALSE;
12454     bool eofmt = FALSE;
12455 #ifdef PERL_MAD
12456     char *tokenstart = s;
12457     SV* savewhite = NULL;
12458
12459     if (PL_madskills) {
12460         savewhite = PL_thiswhite;
12461         PL_thiswhite = 0;
12462     }
12463 #endif
12464
12465     PERL_ARGS_ASSERT_SCAN_FORMLINE;
12466
12467     while (!needargs) {
12468         if (*s == '.') {
12469             t = s+1;
12470 #ifdef PERL_STRICT_CR
12471             while (SPACE_OR_TAB(*t))
12472                 t++;
12473 #else
12474             while (SPACE_OR_TAB(*t) || *t == '\r')
12475                 t++;
12476 #endif
12477             if (*t == '\n' || t == PL_bufend) {
12478                 eofmt = TRUE;
12479                 break;
12480             }
12481         }
12482         if (PL_in_eval && !PL_rsfp) {
12483             eol = (char *) memchr(s,'\n',PL_bufend-s);
12484             if (!eol++)
12485                 eol = PL_bufend;
12486         }
12487         else
12488             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12489         if (*s != '#') {
12490             for (t = s; t < eol; t++) {
12491                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12492                     needargs = FALSE;
12493                     goto enough;        /* ~~ must be first line in formline */
12494                 }
12495                 if (*t == '@' || *t == '^')
12496                     needargs = TRUE;
12497             }
12498             if (eol > s) {
12499                 sv_catpvn(stuff, s, eol-s);
12500 #ifndef PERL_STRICT_CR
12501                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12502                     char *end = SvPVX(stuff) + SvCUR(stuff);
12503                     end[-2] = '\n';
12504                     end[-1] = '\0';
12505                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12506                 }
12507 #endif
12508             }
12509             else
12510               break;
12511         }
12512         s = (char*)eol;
12513         if (PL_rsfp) {
12514 #ifdef PERL_MAD
12515             if (PL_madskills) {
12516                 if (PL_thistoken)
12517                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12518                 else
12519                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12520             }
12521 #endif
12522             s = filter_gets(PL_linestr, PL_rsfp, 0);
12523 #ifdef PERL_MAD
12524             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12525 #else
12526             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12527 #endif
12528             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12529             PL_last_lop = PL_last_uni = NULL;
12530             if (!s) {
12531                 s = PL_bufptr;
12532                 break;
12533             }
12534         }
12535         incline(s);
12536     }
12537   enough:
12538     if (SvCUR(stuff)) {
12539         PL_expect = XTERM;
12540         if (needargs) {
12541             PL_lex_state = LEX_NORMAL;
12542             start_force(PL_curforce);
12543             NEXTVAL_NEXTTOKE.ival = 0;
12544             force_next(',');
12545         }
12546         else
12547             PL_lex_state = LEX_FORMLINE;
12548         if (!IN_BYTES) {
12549             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12550                 SvUTF8_on(stuff);
12551             else if (PL_encoding)
12552                 sv_recode_to_utf8(stuff, PL_encoding);
12553         }
12554         start_force(PL_curforce);
12555         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12556         force_next(THING);
12557         start_force(PL_curforce);
12558         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12559         force_next(LSTOP);
12560     }
12561     else {
12562         SvREFCNT_dec(stuff);
12563         if (eofmt)
12564             PL_lex_formbrack = 0;
12565         PL_bufptr = s;
12566     }
12567 #ifdef PERL_MAD
12568     if (PL_madskills) {
12569         if (PL_thistoken)
12570             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12571         else
12572             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12573         PL_thiswhite = savewhite;
12574     }
12575 #endif
12576     return s;
12577 }
12578
12579 I32
12580 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12581 {
12582     dVAR;
12583     const I32 oldsavestack_ix = PL_savestack_ix;
12584     CV* const outsidecv = PL_compcv;
12585
12586     if (PL_compcv) {
12587         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12588     }
12589     SAVEI32(PL_subline);
12590     save_item(PL_subname);
12591     SAVESPTR(PL_compcv);
12592
12593     PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12594     CvFLAGS(PL_compcv) |= flags;
12595
12596     PL_subline = CopLINE(PL_curcop);
12597     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12598     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12599     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12600
12601     return oldsavestack_ix;
12602 }
12603
12604 #ifdef __SC__
12605 #pragma segment Perl_yylex
12606 #endif
12607 static int
12608 S_yywarn(pTHX_ const char *const s)
12609 {
12610     dVAR;
12611
12612     PERL_ARGS_ASSERT_YYWARN;
12613
12614     PL_in_eval |= EVAL_WARNONLY;
12615     yyerror(s);
12616     PL_in_eval &= ~EVAL_WARNONLY;
12617     return 0;
12618 }
12619
12620 int
12621 Perl_yyerror(pTHX_ const char *const s)
12622 {
12623     dVAR;
12624     const char *where = NULL;
12625     const char *context = NULL;
12626     int contlen = -1;
12627     SV *msg;
12628     int yychar  = PL_parser->yychar;
12629
12630     PERL_ARGS_ASSERT_YYERROR;
12631
12632     if (!yychar || (yychar == ';' && !PL_rsfp))
12633         where = "at EOF";
12634     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12635       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12636       PL_oldbufptr != PL_bufptr) {
12637         /*
12638                 Only for NetWare:
12639                 The code below is removed for NetWare because it abends/crashes on NetWare
12640                 when the script has error such as not having the closing quotes like:
12641                     if ($var eq "value)
12642                 Checking of white spaces is anyway done in NetWare code.
12643         */
12644 #ifndef NETWARE
12645         while (isSPACE(*PL_oldoldbufptr))
12646             PL_oldoldbufptr++;
12647 #endif
12648         context = PL_oldoldbufptr;
12649         contlen = PL_bufptr - PL_oldoldbufptr;
12650     }
12651     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12652       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12653         /*
12654                 Only for NetWare:
12655                 The code below is removed for NetWare because it abends/crashes on NetWare
12656                 when the script has error such as not having the closing quotes like:
12657                     if ($var eq "value)
12658                 Checking of white spaces is anyway done in NetWare code.
12659         */
12660 #ifndef NETWARE
12661         while (isSPACE(*PL_oldbufptr))
12662             PL_oldbufptr++;
12663 #endif
12664         context = PL_oldbufptr;
12665         contlen = PL_bufptr - PL_oldbufptr;
12666     }
12667     else if (yychar > 255)
12668         where = "next token ???";
12669     else if (yychar == -2) { /* YYEMPTY */
12670         if (PL_lex_state == LEX_NORMAL ||
12671            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12672             where = "at end of line";
12673         else if (PL_lex_inpat)
12674             where = "within pattern";
12675         else
12676             where = "within string";
12677     }
12678     else {
12679         SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12680         if (yychar < 32)
12681             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12682         else if (isPRINT_LC(yychar)) {
12683             const char string = yychar;
12684             sv_catpvn(where_sv, &string, 1);
12685         }
12686         else
12687             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12688         where = SvPVX_const(where_sv);
12689     }
12690     msg = sv_2mortal(newSVpv(s, 0));
12691     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12692         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12693     if (context)
12694         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12695     else
12696         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12697     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12698         Perl_sv_catpvf(aTHX_ msg,
12699         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12700                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12701         PL_multi_end = 0;
12702     }
12703     if (PL_in_eval & EVAL_WARNONLY) {
12704         if (ckWARN_d(WARN_SYNTAX))
12705             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12706     }
12707     else
12708         qerror(msg);
12709     if (PL_error_count >= 10) {
12710         if (PL_in_eval && SvCUR(ERRSV))
12711             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12712                        SVfARG(ERRSV), OutCopFILE(PL_curcop));
12713         else
12714             Perl_croak(aTHX_ "%s has too many errors.\n",
12715             OutCopFILE(PL_curcop));
12716     }
12717     PL_in_my = 0;
12718     PL_in_my_stash = NULL;
12719     return 0;
12720 }
12721 #ifdef __SC__
12722 #pragma segment Main
12723 #endif
12724
12725 STATIC char*
12726 S_swallow_bom(pTHX_ U8 *s)
12727 {
12728     dVAR;
12729     const STRLEN slen = SvCUR(PL_linestr);
12730
12731     PERL_ARGS_ASSERT_SWALLOW_BOM;
12732
12733     switch (s[0]) {
12734     case 0xFF:
12735         if (s[1] == 0xFE) {
12736             /* UTF-16 little-endian? (or UTF32-LE?) */
12737             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
12738                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12739 #ifndef PERL_NO_UTF16_FILTER
12740             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12741             s += 2;
12742         utf16le:
12743             if (PL_bufend > (char*)s) {
12744                 U8 *news;
12745                 I32 newlen;
12746
12747                 filter_add(utf16rev_textfilter, NULL);
12748                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12749                 utf16_to_utf8_reversed(s, news,
12750                                        PL_bufend - (char*)s - 1,
12751                                        &newlen);
12752                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12753 #ifdef PERL_MAD
12754                 s = (U8*)SvPVX(PL_linestr);
12755                 Copy(news, s, newlen, U8);
12756                 s[newlen] = '\0';
12757 #endif
12758                 Safefree(news);
12759                 SvUTF8_on(PL_linestr);
12760                 s = (U8*)SvPVX(PL_linestr);
12761 #ifdef PERL_MAD
12762                 /* FIXME - is this a general bug fix?  */
12763                 s[newlen] = '\0';
12764 #endif
12765                 PL_bufend = SvPVX(PL_linestr) + newlen;
12766             }
12767 #else
12768             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12769 #endif
12770         }
12771         break;
12772     case 0xFE:
12773         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
12774 #ifndef PERL_NO_UTF16_FILTER
12775             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12776             s += 2;
12777         utf16be:
12778             if (PL_bufend > (char *)s) {
12779                 U8 *news;
12780                 I32 newlen;
12781
12782                 filter_add(utf16_textfilter, NULL);
12783                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12784                 utf16_to_utf8(s, news,
12785                               PL_bufend - (char*)s,
12786                               &newlen);
12787                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12788                 Safefree(news);
12789                 SvUTF8_on(PL_linestr);
12790                 s = (U8*)SvPVX(PL_linestr);
12791                 PL_bufend = SvPVX(PL_linestr) + newlen;
12792             }
12793 #else
12794             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12795 #endif
12796         }
12797         break;
12798     case 0xEF:
12799         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12800             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12801             s += 3;                      /* UTF-8 */
12802         }
12803         break;
12804     case 0:
12805         if (slen > 3) {
12806              if (s[1] == 0) {
12807                   if (s[2] == 0xFE && s[3] == 0xFF) {
12808                        /* UTF-32 big-endian */
12809                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12810                   }
12811              }
12812              else if (s[2] == 0 && s[3] != 0) {
12813                   /* Leading bytes
12814                    * 00 xx 00 xx
12815                    * are a good indicator of UTF-16BE. */
12816                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12817                   goto utf16be;
12818              }
12819         }
12820 #ifdef EBCDIC
12821     case 0xDD:
12822         if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12823             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12824             s += 4;                      /* UTF-8 */
12825         }
12826         break;
12827 #endif
12828
12829     default:
12830          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12831                   /* Leading bytes
12832                    * xx 00 xx 00
12833                    * are a good indicator of UTF-16LE. */
12834               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12835               goto utf16le;
12836          }
12837     }
12838     return (char*)s;
12839 }
12840
12841
12842 #ifndef PERL_NO_UTF16_FILTER
12843 static I32
12844 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12845 {
12846     dVAR;
12847     const STRLEN old = SvCUR(sv);
12848     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12849     DEBUG_P(PerlIO_printf(Perl_debug_log,
12850                           "utf16_textfilter(%p): %d %d (%d)\n",
12851                           FPTR2DPTR(void *, utf16_textfilter),
12852                           idx, maxlen, (int) count));
12853     if (count) {
12854         U8* tmps;
12855         I32 newlen;
12856         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12857         Copy(SvPVX_const(sv), tmps, old, char);
12858         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12859                       SvCUR(sv) - old, &newlen);
12860         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12861     }
12862     DEBUG_P({sv_dump(sv);});
12863     return SvCUR(sv);
12864 }
12865
12866 static I32
12867 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12868 {
12869     dVAR;
12870     const STRLEN old = SvCUR(sv);
12871     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12872     DEBUG_P(PerlIO_printf(Perl_debug_log,
12873                           "utf16rev_textfilter(%p): %d %d (%d)\n",
12874                           FPTR2DPTR(void *, utf16rev_textfilter),
12875                           idx, maxlen, (int) count));
12876     if (count) {
12877         U8* tmps;
12878         I32 newlen;
12879         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12880         Copy(SvPVX_const(sv), tmps, old, char);
12881         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12882                       SvCUR(sv) - old, &newlen);
12883         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12884     }
12885     DEBUG_P({ sv_dump(sv); });
12886     return count;
12887 }
12888 #endif
12889
12890 /*
12891 Returns a pointer to the next character after the parsed
12892 vstring, as well as updating the passed in sv.
12893
12894 Function must be called like
12895
12896         sv = newSV(5);
12897         s = scan_vstring(s,e,sv);
12898
12899 where s and e are the start and end of the string.
12900 The sv should already be large enough to store the vstring
12901 passed in, for performance reasons.
12902
12903 */
12904
12905 char *
12906 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12907 {
12908     dVAR;
12909     const char *pos = s;
12910     const char *start = s;
12911
12912     PERL_ARGS_ASSERT_SCAN_VSTRING;
12913
12914     if (*pos == 'v') pos++;  /* get past 'v' */
12915     while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12916         pos++;
12917     if ( *pos != '.') {
12918         /* this may not be a v-string if followed by => */
12919         const char *next = pos;
12920         while (next < e && isSPACE(*next))
12921             ++next;
12922         if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12923             /* return string not v-string */
12924             sv_setpvn(sv,(char *)s,pos-s);
12925             return (char *)pos;
12926         }
12927     }
12928
12929     if (!isALPHA(*pos)) {
12930         U8 tmpbuf[UTF8_MAXBYTES+1];
12931
12932         if (*s == 'v')
12933             s++;  /* get past 'v' */
12934
12935         sv_setpvs(sv, "");
12936
12937         for (;;) {
12938             /* this is atoi() that tolerates underscores */
12939             U8 *tmpend;
12940             UV rev = 0;
12941             const char *end = pos;
12942             UV mult = 1;
12943             while (--end >= s) {
12944                 if (*end != '_') {
12945                     const UV orev = rev;
12946                     rev += (*end - '0') * mult;
12947                     mult *= 10;
12948                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12949                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12950                                     "Integer overflow in decimal number");
12951                 }
12952             }
12953 #ifdef EBCDIC
12954             if (rev > 0x7FFFFFFF)
12955                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12956 #endif
12957             /* Append native character for the rev point */
12958             tmpend = uvchr_to_utf8(tmpbuf, rev);
12959             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12960             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12961                  SvUTF8_on(sv);
12962             if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12963                  s = ++pos;
12964             else {
12965                  s = pos;
12966                  break;
12967             }
12968             while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12969                  pos++;
12970         }
12971         SvPOK_on(sv);
12972         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12973         SvRMAGICAL_on(sv);
12974     }
12975     return (char *)s;
12976 }
12977
12978 /*
12979  * Local variables:
12980  * c-indentation-style: bsd
12981  * c-basic-offset: 4
12982  * indent-tabs-mode: t
12983  * End:
12984  *
12985  * ex: set ts=8 sts=4 sw=4 noet:
12986  */