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