toke.c

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