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