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