toke.c

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