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