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