toke.c

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