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