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