toke.c

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