toke.c

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