toke.c

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