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