toke.c

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