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