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