toke.c

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