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