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_lex_state = LEX_NORMAL;
 681     PL_expect = XSTATE;
 682     Newx(parser->lex_brackstack, 120, char);
 683     Newx(parser->lex_casestack, 12, char);
 684     *parser->lex_casestack = '\0';
 685 #ifndef PERL_MAD
 686     PL_nexttoke = 0;
 687 #endif
 688
 689     if (line) {
 690         s = SvPV_const(line, len);
 691     } else {
 692         len = 0;
 693     }
 694     if (!len) {
 695         PL_linestr = newSVpvs("\n;");
 696     } else if (SvREADONLY(line) || s[len-1] != ';') {
 697         PL_linestr = newSVsv(line);
 698         if (s[len-1] != ';')
 699             sv_catpvs(PL_linestr, "\n;");
 700     } else {
 701         SvTEMP_off(line);
 702         SvREFCNT_inc_simple_void_NN(line);
 703         PL_linestr = line;
 704     }
 705     /* PL_linestr needs to survive until end of scope, not just the next
 706        FREETMPS. See changes 17505 and 17546 which fixed the symptoms only.  */
 707     SAVEFREESV(PL_linestr);
 708     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 709     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 710     PL_last_lop = PL_last_uni = NULL;
 711     PL_rsfp = 0;
 712 }
 713
 714 /*
 715  * Perl_lex_end
 716  * Finalizer for lexing operations.  Must be called when the parser is
 717  * done with the lexer.
 718  */
 719
 720 void
 721 Perl_lex_end(pTHX)
 722 {
 723     dVAR;
 724     PL_doextract = FALSE;
 725 }
 726
 727 /*
 728  * S_incline
 729  * This subroutine has nothing to do with tilting, whether at windmills
 730  * or pinball tables.  Its name is short for "increment line".  It
 731  * increments the current line number in CopLINE(PL_curcop) and checks
 732  * to see whether the line starts with a comment of the form
 733  *    # line 500 "foo.pm"
 734  * If so, it sets the current line number and file to the values in the comment.
 735  */
 736
 737 STATIC void
 738 S_incline(pTHX_ const char *s)
 739 {
 740     dVAR;
 741     const char *t;
 742     const char *n;
 743     const char *e;
 744
 745     CopLINE_inc(PL_curcop);
 746     if (*s++ != '#')
 747         return;
 748     while (SPACE_OR_TAB(*s))
 749         s++;
 750     if (strnEQ(s, "line", 4))
 751         s += 4;
 752     else
 753         return;
 754     if (SPACE_OR_TAB(*s))
 755         s++;
 756     else
 757         return;
 758     while (SPACE_OR_TAB(*s))
 759         s++;
 760     if (!isDIGIT(*s))
 761         return;
 762
 763     n = s;
 764     while (isDIGIT(*s))
 765         s++;
 766     while (SPACE_OR_TAB(*s))
 767         s++;
 768     if (*s == '"' && (t = strchr(s+1, '"'))) {
 769         s++;
 770         e = t + 1;
 771     }
 772     else {
 773         t = s;
 774         while (!isSPACE(*t))
 775             t++;
 776         e = t;
 777     }
 778     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 779         e++;
 780     if (*e != '\n' && *e != '\0')
 781         return;         /* false alarm */
 782
 783     if (t - s > 0) {
 784         const STRLEN len = t - s;
 785 #ifndef USE_ITHREADS
 786         const char * const cf = CopFILE(PL_curcop);
 787         STRLEN tmplen = cf ? strlen(cf) : 0;
 788         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 789             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 790              * to *{"::_<newfilename"} */
 791             /* However, the long form of evals is only turned on by the
 792                debugger - usually they're "(eval %lu)" */
 793             char smallbuf[128];
 794             char *tmpbuf;
 795             GV **gvp;
 796             STRLEN tmplen2 = len;
 797             if (tmplen + 2 <= sizeof smallbuf)
 798                 tmpbuf = smallbuf;
 799             else
 800                 Newx(tmpbuf, tmplen + 2, char);
 801             tmpbuf[0] = '_';
 802             tmpbuf[1] = '<';
 803             memcpy(tmpbuf + 2, cf, tmplen);
 804             tmplen += 2;
 805             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 806             if (gvp) {
 807                 char *tmpbuf2;
 808                 GV *gv2;
 809
 810                 if (tmplen2 + 2 <= sizeof smallbuf)
 811                     tmpbuf2 = smallbuf;
 812                 else
 813                     Newx(tmpbuf2, tmplen2 + 2, char);
 814
 815                 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
 816                     /* Either they malloc'd it, or we malloc'd it,
 817                        so no prefix is present in ours.  */
 818                     tmpbuf2[0] = '_';
 819                     tmpbuf2[1] = '<';
 820                 }
 821
 822                 memcpy(tmpbuf2 + 2, s, tmplen2);
 823                 tmplen2 += 2;
 824
 825                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 826                 if (!isGV(gv2)) {
 827                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 828                     /* adjust ${"::_<newfilename"} to store the new file name */
 829                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 830                     GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
 831                     GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
 832                 }
 833
 834                 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
 835             }
 836             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 837         }
 838 #endif
 839         CopFILE_free(PL_curcop);
 840         CopFILE_setn(PL_curcop, s, len);
 841     }
 842     CopLINE_set(PL_curcop, atoi(n)-1);
 843 }
 844
 845 #ifdef PERL_MAD
 846 /* skip space before PL_thistoken */
 847
 848 STATIC char *
 849 S_skipspace0(pTHX_ register char *s)
 850 {
 851     s = skipspace(s);
 852     if (!PL_madskills)
 853         return s;
 854     if (PL_skipwhite) {
 855         if (!PL_thiswhite)
 856             PL_thiswhite = newSVpvs("");
 857         sv_catsv(PL_thiswhite, PL_skipwhite);
 858         sv_free(PL_skipwhite);
 859         PL_skipwhite = 0;
 860     }
 861     PL_realtokenstart = s - SvPVX(PL_linestr);
 862     return s;
 863 }
 864
 865 /* skip space after PL_thistoken */
 866
 867 STATIC char *
 868 S_skipspace1(pTHX_ register char *s)
 869 {
 870     const char *start = s;
 871     I32 startoff = start - SvPVX(PL_linestr);
 872
 873     s = skipspace(s);
 874     if (!PL_madskills)
 875         return s;
 876     start = SvPVX(PL_linestr) + startoff;
 877     if (!PL_thistoken && PL_realtokenstart >= 0) {
 878         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 879         PL_thistoken = newSVpvn(tstart, start - tstart);
 880     }
 881     PL_realtokenstart = -1;
 882     if (PL_skipwhite) {
 883         if (!PL_nextwhite)
 884             PL_nextwhite = newSVpvs("");
 885         sv_catsv(PL_nextwhite, PL_skipwhite);
 886         sv_free(PL_skipwhite);
 887         PL_skipwhite = 0;
 888     }
 889     return s;
 890 }
 891
 892 STATIC char *
 893 S_skipspace2(pTHX_ register char *s, SV **svp)
 894 {
 895     char *start;
 896     const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 897     const I32 startoff = s - SvPVX(PL_linestr);
 898
 899     s = skipspace(s);
 900     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 901     if (!PL_madskills || !svp)
 902         return s;
 903     start = SvPVX(PL_linestr) + startoff;
 904     if (!PL_thistoken && PL_realtokenstart >= 0) {
 905         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 906         PL_thistoken = newSVpvn(tstart, start - tstart);
 907         PL_realtokenstart = -1;
 908     }
 909     if (PL_skipwhite) {
 910         if (!*svp)
 911             *svp = newSVpvs("");
 912         sv_setsv(*svp, PL_skipwhite);
 913         sv_free(PL_skipwhite);
 914         PL_skipwhite = 0;
 915     }
 916
 917     return s;
 918 }
 919 #endif
 920
 921 STATIC void
 922 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
 923 {
 924     AV *av = CopFILEAVx(PL_curcop);
 925     if (av) {
 926         SV * const sv = newSV(0);
 927         sv_upgrade(sv, 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_catpv(PL_linestr,
1030                          ";}continue{print or die qq(-p destination: $!\\n);}");
1031 #else
1032                 sv_setpv(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] == 'p' || 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, sizeof PL_tokenbuf - 1, TRUE);
4136         if (!PL_tokenbuf[1]) {
4137             PREREF('%');
4138         }
4139         PL_pending_ident = '%';
4140         TERM('%');
4141
4142     case '^':
4143         s++;
4144         BOop(OP_BIT_XOR);
4145     case '[':
4146         PL_lex_brackets++;
4147         /* FALL THROUGH */
4148     case '~':
4149         if (s[1] == '~'
4150             && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4151         {
4152             s += 2;
4153             Eop(OP_SMARTMATCH);
4154         }
4155     case ',':
4156         {
4157             const char tmp = *s++;
4158             OPERATOR(tmp);
4159         }
4160     case ':':
4161         if (s[1] == ':') {
4162             len = 0;
4163             goto just_a_word_zero_gv;
4164         }
4165         s++;
4166         switch (PL_expect) {
4167             OP *attrs;
4168 #ifdef PERL_MAD
4169             I32 stuffstart;
4170 #endif
4171         case XOPERATOR:
4172             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4173                 break;
4174             PL_bufptr = s;      /* update in case we back off */
4175             goto grabattrs;
4176         case XATTRBLOCK:
4177             PL_expect = XBLOCK;
4178             goto grabattrs;
4179         case XATTRTERM:
4180             PL_expect = XTERMBLOCK;
4181          grabattrs:
4182 #ifdef PERL_MAD
4183             stuffstart = s - SvPVX(PL_linestr) - 1;
4184 #endif
4185             s = PEEKSPACE(s);
4186             attrs = NULL;
4187             while (isIDFIRST_lazy_if(s,UTF)) {
4188                 I32 tmp;
4189                 SV *sv;
4190                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4191                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4192                     if (tmp < 0) tmp = -tmp;
4193                     switch (tmp) {
4194                     case KEY_or:
4195                     case KEY_and:
4196                     case KEY_err:
4197                     case KEY_for:
4198                     case KEY_unless:
4199                     case KEY_if:
4200                     case KEY_while:
4201                     case KEY_until:
4202                         goto got_attrs;
4203                     default:
4204                         break;
4205                     }
4206                 }
4207                 sv = newSVpvn(s, len);
4208                 if (*d == '(') {
4209                     d = scan_str(d,TRUE,TRUE);
4210                     if (!d) {
4211                         /* MUST advance bufptr here to avoid bogus
4212                            "at end of line" context messages from yyerror().
4213                          */
4214                         PL_bufptr = s + len;
4215                         yyerror("Unterminated attribute parameter in attribute list");
4216                         if (attrs)
4217                             op_free(attrs);
4218                         sv_free(sv);
4219                         return REPORT(0);       /* EOF indicator */
4220                     }
4221                 }
4222                 if (PL_lex_stuff) {
4223                     sv_catsv(sv, PL_lex_stuff);
4224                     attrs = append_elem(OP_LIST, attrs,
4225                                         newSVOP(OP_CONST, 0, sv));
4226                     SvREFCNT_dec(PL_lex_stuff);
4227                     PL_lex_stuff = NULL;
4228                 }
4229                 else {
4230                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4231                         sv_free(sv);
4232                         if (PL_in_my == KEY_our) {
4233 #ifdef USE_ITHREADS
4234                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4235 #else
4236                             /* skip to avoid loading attributes.pm */
4237 #endif
4238                             deprecate(":unique");
4239                         }
4240                         else
4241                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4242                     }
4243
4244                     /* NOTE: any CV attrs applied here need to be part of
4245                        the CVf_BUILTIN_ATTRS define in cv.h! */
4246                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4247                         sv_free(sv);
4248                         CvLVALUE_on(PL_compcv);
4249                     }
4250                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4251                         sv_free(sv);
4252                         CvLOCKED_on(PL_compcv);
4253                     }
4254                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4255                         sv_free(sv);
4256                         CvMETHOD_on(PL_compcv);
4257                     }
4258                     else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4259                         sv_free(sv);
4260                         CvASSERTION_on(PL_compcv);
4261                     }
4262                     /* After we've set the flags, it could be argued that
4263                        we don't need to do the attributes.pm-based setting
4264                        process, and shouldn't bother appending recognized
4265                        flags.  To experiment with that, uncomment the
4266                        following "else".  (Note that's already been
4267                        uncommented.  That keeps the above-applied built-in
4268                        attributes from being intercepted (and possibly
4269                        rejected) by a package's attribute routines, but is
4270                        justified by the performance win for the common case
4271                        of applying only built-in attributes.) */
4272                     else
4273                         attrs = append_elem(OP_LIST, attrs,
4274                                             newSVOP(OP_CONST, 0,
4275                                                     sv));
4276                 }
4277                 s = PEEKSPACE(d);
4278                 if (*s == ':' && s[1] != ':')
4279                     s = PEEKSPACE(s+1);
4280                 else if (s == d)
4281                     break;      /* require real whitespace or :'s */
4282                 /* XXX losing whitespace on sequential attributes here */
4283             }
4284             {
4285                 const char tmp
4286                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4287                 if (*s != ';' && *s != '}' && *s != tmp
4288                     && (tmp != '=' || *s != ')')) {
4289                     const char q = ((*s == '\'') ? '"' : '\'');
4290                     /* If here for an expression, and parsed no attrs, back
4291                        off. */
4292                     if (tmp == '=' && !attrs) {
4293                         s = PL_bufptr;
4294                         break;
4295                     }
4296                     /* MUST advance bufptr here to avoid bogus "at end of line"
4297                        context messages from yyerror().
4298                     */
4299                     PL_bufptr = s;
4300                     yyerror( (const char *)
4301                              (*s
4302                               ? Perl_form(aTHX_ "Invalid separator character "
4303                                           "%c%c%c in attribute list", q, *s, q)
4304                               : "Unterminated attribute list" ) );
4305                     if (attrs)
4306                         op_free(attrs);
4307                     OPERATOR(':');
4308                 }
4309             }
4310         got_attrs:
4311             if (attrs) {
4312                 start_force(PL_curforce);
4313                 NEXTVAL_NEXTTOKE.opval = attrs;
4314                 CURMAD('_', PL_nextwhite);
4315                 force_next(THING);
4316             }
4317 #ifdef PERL_MAD
4318             if (PL_madskills) {
4319                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4320                                      (s - SvPVX(PL_linestr)) - stuffstart);
4321             }
4322 #endif
4323             TOKEN(COLONATTR);
4324         }
4325         OPERATOR(':');
4326     case '(':
4327         s++;
4328         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4329             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4330         else
4331             PL_expect = XTERM;
4332         s = SKIPSPACE1(s);
4333         TOKEN('(');
4334     case ';':
4335         CLINE;
4336         {
4337             const char tmp = *s++;
4338             OPERATOR(tmp);
4339         }
4340     case ')':
4341         {
4342             const char tmp = *s++;
4343             s = SKIPSPACE1(s);
4344             if (*s == '{')
4345                 PREBLOCK(tmp);
4346             TERM(tmp);
4347         }
4348     case ']':
4349         s++;
4350         if (PL_lex_brackets <= 0)
4351             yyerror("Unmatched right square bracket");
4352         else
4353             --PL_lex_brackets;
4354         if (PL_lex_state == LEX_INTERPNORMAL) {
4355             if (PL_lex_brackets == 0) {
4356                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4357                     PL_lex_state = LEX_INTERPEND;
4358             }
4359         }
4360         TERM(']');
4361     case '{':
4362       leftbracket:
4363         s++;
4364         if (PL_lex_brackets > 100) {
4365             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4366         }
4367         switch (PL_expect) {
4368         case XTERM:
4369             if (PL_lex_formbrack) {
4370                 s--;
4371                 PRETERMBLOCK(DO);
4372             }
4373             if (PL_oldoldbufptr == PL_last_lop)
4374                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4375             else
4376                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4377             OPERATOR(HASHBRACK);
4378         case XOPERATOR:
4379             while (s < PL_bufend && SPACE_OR_TAB(*s))
4380                 s++;
4381             d = s;
4382             PL_tokenbuf[0] = '\0';
4383             if (d < PL_bufend && *d == '-') {
4384                 PL_tokenbuf[0] = '-';
4385                 d++;
4386                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4387                     d++;
4388             }
4389             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4390                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4391                               FALSE, &len);
4392                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4393                     d++;
4394                 if (*d == '}') {
4395                     const char minus = (PL_tokenbuf[0] == '-');
4396                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4397                     if (minus)
4398                         force_next('-');
4399                 }
4400             }
4401             /* FALL THROUGH */
4402         case XATTRBLOCK:
4403         case XBLOCK:
4404             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4405             PL_expect = XSTATE;
4406             break;
4407         case XATTRTERM:
4408         case XTERMBLOCK:
4409             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4410             PL_expect = XSTATE;
4411             break;
4412         default: {
4413                 const char *t;
4414                 if (PL_oldoldbufptr == PL_last_lop)
4415                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4416                 else
4417                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4418                 s = SKIPSPACE1(s);
4419                 if (*s == '}') {
4420                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4421                         PL_expect = XTERM;
4422                         /* This hack is to get the ${} in the message. */
4423                         PL_bufptr = s+1;
4424                         yyerror("syntax error");
4425                         break;
4426                     }
4427                     OPERATOR(HASHBRACK);
4428                 }
4429                 /* This hack serves to disambiguate a pair of curlies
4430                  * as being a block or an anon hash.  Normally, expectation
4431                  * determines that, but in cases where we're not in a
4432                  * position to expect anything in particular (like inside
4433                  * eval"") we have to resolve the ambiguity.  This code
4434                  * covers the case where the first term in the curlies is a
4435                  * quoted string.  Most other cases need to be explicitly
4436                  * disambiguated by prepending a "+" before the opening
4437                  * curly in order to force resolution as an anon hash.
4438                  *
4439                  * XXX should probably propagate the outer expectation
4440                  * into eval"" to rely less on this hack, but that could
4441                  * potentially break current behavior of eval"".
4442                  * GSAR 97-07-21
4443                  */
4444                 t = s;
4445                 if (*s == '\'' || *s == '"' || *s == '`') {
4446                     /* common case: get past first string, handling escapes */
4447                     for (t++; t < PL_bufend && *t != *s;)
4448                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4449                             t++;
4450                     t++;
4451                 }
4452                 else if (*s == 'q') {
4453                     if (++t < PL_bufend
4454                         && (!isALNUM(*t)
4455                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4456                                 && !isALNUM(*t))))
4457                     {
4458                         /* skip q//-like construct */
4459                         const char *tmps;
4460                         char open, close, term;
4461                         I32 brackets = 1;
4462
4463                         while (t < PL_bufend && isSPACE(*t))
4464                             t++;
4465                         /* check for q => */
4466                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4467                             OPERATOR(HASHBRACK);
4468                         }
4469                         term = *t;
4470                         open = term;
4471                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4472                             term = tmps[5];
4473                         close = term;
4474                         if (open == close)
4475                             for (t++; t < PL_bufend; t++) {
4476                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4477                                     t++;
4478                                 else if (*t == open)
4479                                     break;
4480                             }
4481                         else {
4482                             for (t++; t < PL_bufend; t++) {
4483                                 if (*t == '\\' && t+1 < PL_bufend)
4484                                     t++;
4485                                 else if (*t == close && --brackets <= 0)
4486                                     break;
4487                                 else if (*t == open)
4488                                     brackets++;
4489                             }
4490                         }
4491                         t++;
4492                     }
4493                     else
4494                         /* skip plain q word */
4495                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4496                              t += UTF8SKIP(t);
4497                 }
4498                 else if (isALNUM_lazy_if(t,UTF)) {
4499                     t += UTF8SKIP(t);
4500                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4501                          t += UTF8SKIP(t);
4502                 }
4503                 while (t < PL_bufend && isSPACE(*t))
4504                     t++;
4505                 /* if comma follows first term, call it an anon hash */
4506                 /* XXX it could be a comma expression with loop modifiers */
4507                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4508                                    || (*t == '=' && t[1] == '>')))
4509                     OPERATOR(HASHBRACK);
4510                 if (PL_expect == XREF)
4511                     PL_expect = XTERM;
4512                 else {
4513                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4514                     PL_expect = XSTATE;
4515                 }
4516             }
4517             break;
4518         }
4519         yylval.ival = CopLINE(PL_curcop);
4520         if (isSPACE(*s) || *s == '#')
4521             PL_copline = NOLINE;   /* invalidate current command line number */
4522         TOKEN('{');
4523     case '}':
4524       rightbracket:
4525         s++;
4526         if (PL_lex_brackets <= 0)
4527             yyerror("Unmatched right curly bracket");
4528         else
4529             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4530         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4531             PL_lex_formbrack = 0;
4532         if (PL_lex_state == LEX_INTERPNORMAL) {
4533             if (PL_lex_brackets == 0) {
4534                 if (PL_expect & XFAKEBRACK) {
4535                     PL_expect &= XENUMMASK;
4536                     PL_lex_state = LEX_INTERPEND;
4537                     PL_bufptr = s;
4538 #if 0
4539                     if (PL_madskills) {
4540                         if (!PL_thiswhite)
4541                             PL_thiswhite = newSVpvs("");
4542                         sv_catpvn(PL_thiswhite,"}",1);
4543                     }
4544 #endif
4545                     return yylex();     /* ignore fake brackets */
4546                 }
4547                 if (*s == '-' && s[1] == '>')
4548                     PL_lex_state = LEX_INTERPENDMAYBE;
4549                 else if (*s != '[' && *s != '{')
4550                     PL_lex_state = LEX_INTERPEND;
4551             }
4552         }
4553         if (PL_expect & XFAKEBRACK) {
4554             PL_expect &= XENUMMASK;
4555             PL_bufptr = s;
4556             return yylex();             /* ignore fake brackets */
4557         }
4558         start_force(PL_curforce);
4559         if (PL_madskills) {
4560             curmad('X', newSVpvn(s-1,1));
4561             CURMAD('_', PL_thiswhite);
4562         }
4563         force_next('}');
4564 #ifdef PERL_MAD
4565         if (!PL_thistoken)
4566             PL_thistoken = newSVpvs("");
4567 #endif
4568         TOKEN(';');
4569     case '&':
4570         s++;
4571         if (*s++ == '&')
4572             AOPERATOR(ANDAND);
4573         s--;
4574         if (PL_expect == XOPERATOR) {
4575             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4576                 && isIDFIRST_lazy_if(s,UTF))
4577             {
4578                 CopLINE_dec(PL_curcop);
4579                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4580                 CopLINE_inc(PL_curcop);
4581             }
4582             BAop(OP_BIT_AND);
4583         }
4584
4585         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4586         if (*PL_tokenbuf) {
4587             PL_expect = XOPERATOR;
4588             force_ident(PL_tokenbuf, '&');
4589         }
4590         else
4591             PREREF('&');
4592         yylval.ival = (OPpENTERSUB_AMPER<<8);
4593         TERM('&');
4594
4595     case '|':
4596         s++;
4597         if (*s++ == '|')
4598             AOPERATOR(OROR);
4599         s--;
4600         BOop(OP_BIT_OR);
4601     case '=':
4602         s++;
4603         {
4604             const char tmp = *s++;
4605             if (tmp == '=')
4606                 Eop(OP_EQ);
4607             if (tmp == '>')
4608                 OPERATOR(',');
4609             if (tmp == '~')
4610                 PMop(OP_MATCH);
4611             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4612                 && strchr("+-*/%.^&|<",tmp))
4613                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4614                             "Reversed %c= operator",(int)tmp);
4615             s--;
4616             if (PL_expect == XSTATE && isALPHA(tmp) &&
4617                 (s == PL_linestart+1 || s[-2] == '\n') )
4618                 {
4619                     if (PL_in_eval && !PL_rsfp) {
4620                         d = PL_bufend;
4621                         while (s < d) {
4622                             if (*s++ == '\n') {
4623                                 incline(s);
4624                                 if (strnEQ(s,"=cut",4)) {
4625                                     s = strchr(s,'\n');
4626                                     if (s)
4627                                         s++;
4628                                     else
4629                                         s = d;
4630                                     incline(s);
4631                                     goto retry;
4632                                 }
4633                             }
4634                         }
4635                         goto retry;
4636                     }
4637 #ifdef PERL_MAD
4638                     if (PL_madskills) {
4639                         if (!PL_thiswhite)
4640                             PL_thiswhite = newSVpvs("");
4641                         sv_catpvn(PL_thiswhite, PL_linestart,
4642                                   PL_bufend - PL_linestart);
4643                     }
4644 #endif
4645                     s = PL_bufend;
4646                     PL_doextract = TRUE;
4647                     goto retry;
4648                 }
4649         }
4650         if (PL_lex_brackets < PL_lex_formbrack) {
4651             const char *t = s;
4652 #ifdef PERL_STRICT_CR
4653             while (SPACE_OR_TAB(*t))
4654 #else
4655             while (SPACE_OR_TAB(*t) || *t == '\r')
4656 #endif
4657                 t++;
4658             if (*t == '\n' || *t == '#') {
4659                 s--;
4660                 PL_expect = XBLOCK;
4661                 goto leftbracket;
4662             }
4663         }
4664         yylval.ival = 0;
4665         OPERATOR(ASSIGNOP);
4666     case '!':
4667         s++;
4668         {
4669             const char tmp = *s++;
4670             if (tmp == '=') {
4671                 /* was this !=~ where !~ was meant?
4672                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4673
4674                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4675                     const char *t = s+1;
4676
4677                     while (t < PL_bufend && isSPACE(*t))
4678                         ++t;
4679
4680                     if (*t == '/' || *t == '?' ||
4681                         ((*t == 'm' || *t == 's' || *t == 'y')
4682                          && !isALNUM(t[1])) ||
4683                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4684                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4685                                     "!=~ should be !~");
4686                 }
4687                 Eop(OP_NE);
4688             }
4689             if (tmp == '~')
4690                 PMop(OP_NOT);
4691         }
4692         s--;
4693         OPERATOR('!');
4694     case '<':
4695         if (PL_expect != XOPERATOR) {
4696             if (s[1] != '<' && !strchr(s,'>'))
4697                 check_uni();
4698             if (s[1] == '<')
4699                 s = scan_heredoc(s);
4700             else
4701                 s = scan_inputsymbol(s);
4702             TERM(sublex_start());
4703         }
4704         s++;
4705         {
4706             char tmp = *s++;
4707             if (tmp == '<')
4708                 SHop(OP_LEFT_SHIFT);
4709             if (tmp == '=') {
4710                 tmp = *s++;
4711                 if (tmp == '>')
4712                     Eop(OP_NCMP);
4713                 s--;
4714                 Rop(OP_LE);
4715             }
4716         }
4717         s--;
4718         Rop(OP_LT);
4719     case '>':
4720         s++;
4721         {
4722             const char tmp = *s++;
4723             if (tmp == '>')
4724                 SHop(OP_RIGHT_SHIFT);
4725             else if (tmp == '=')
4726                 Rop(OP_GE);
4727         }
4728         s--;
4729         Rop(OP_GT);
4730
4731     case '$':
4732         CLINE;
4733
4734         if (PL_expect == XOPERATOR) {
4735             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4736                 PL_expect = XTERM;
4737                 deprecate_old(commaless_variable_list);
4738                 return REPORT(','); /* grandfather non-comma-format format */
4739             }
4740         }
4741
4742         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4743             PL_tokenbuf[0] = '@';
4744             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4745                            sizeof PL_tokenbuf - 1, FALSE);
4746             if (PL_expect == XOPERATOR)
4747                 no_op("Array length", s);
4748             if (!PL_tokenbuf[1])
4749                 PREREF(DOLSHARP);
4750             PL_expect = XOPERATOR;
4751             PL_pending_ident = '#';
4752             TOKEN(DOLSHARP);
4753         }
4754
4755         PL_tokenbuf[0] = '$';
4756         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4757                        sizeof PL_tokenbuf - 1, FALSE);
4758         if (PL_expect == XOPERATOR)
4759             no_op("Scalar", s);
4760         if (!PL_tokenbuf[1]) {
4761             if (s == PL_bufend)
4762                 yyerror("Final $ should be \\$ or $name");
4763             PREREF('$');
4764         }
4765
4766         /* This kludge not intended to be bulletproof. */
4767         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4768             yylval.opval = newSVOP(OP_CONST, 0,
4769                                    newSViv(CopARYBASE_get(&PL_compiling)));
4770             yylval.opval->op_private = OPpCONST_ARYBASE;
4771             TERM(THING);
4772         }
4773
4774         d = s;
4775         {
4776             const char tmp = *s;
4777             if (PL_lex_state == LEX_NORMAL)
4778                 s = SKIPSPACE1(s);
4779
4780             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4781                 && intuit_more(s)) {
4782                 if (*s == '[') {
4783                     PL_tokenbuf[0] = '@';
4784                     if (ckWARN(WARN_SYNTAX)) {
4785                         char *t = s+1;
4786
4787                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4788                             t++;
4789                         if (*t++ == ',') {
4790                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4791                             while (t < PL_bufend && *t != ']')
4792                                 t++;
4793                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4794                                         "Multidimensional syntax %.*s not supported",
4795                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4796                         }
4797                     }
4798                 }
4799                 else if (*s == '{') {
4800                     char *t;
4801                     PL_tokenbuf[0] = '%';
4802                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4803                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4804                         {
4805                             char tmpbuf[sizeof PL_tokenbuf];
4806                             do {
4807                                 t++;
4808                             } while (isSPACE(*t));
4809                             if (isIDFIRST_lazy_if(t,UTF)) {
4810                                 STRLEN len;
4811                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4812                                               &len);
4813                                 while (isSPACE(*t))
4814                                     t++;
4815                                 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4816                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4817                                                 "You need to quote \"%s\"",
4818                                                 tmpbuf);
4819                             }
4820                         }
4821                 }
4822             }
4823
4824             PL_expect = XOPERATOR;
4825             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4826                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4827                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4828                     PL_expect = XOPERATOR;
4829                 else if (strchr("$@\"'`q", *s))
4830                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4831                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4832                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4833                 else if (isIDFIRST_lazy_if(s,UTF)) {
4834                     char tmpbuf[sizeof PL_tokenbuf];
4835                     int t2;
4836                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4837                     if ((t2 = keyword(tmpbuf, len, 0))) {
4838                         /* binary operators exclude handle interpretations */
4839                         switch (t2) {
4840                         case -KEY_x:
4841                         case -KEY_eq:
4842                         case -KEY_ne:
4843                         case -KEY_gt:
4844                         case -KEY_lt:
4845                         case -KEY_ge:
4846                         case -KEY_le:
4847                         case -KEY_cmp:
4848                             break;
4849                         default:
4850                             PL_expect = XTERM;  /* e.g. print $fh length() */
4851                             break;
4852                         }
4853                     }
4854                     else {
4855                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4856                     }
4857                 }
4858                 else if (isDIGIT(*s))
4859                     PL_expect = XTERM;          /* e.g. print $fh 3 */
4860                 else if (*s == '.' && isDIGIT(s[1]))
4861                     PL_expect = XTERM;          /* e.g. print $fh .3 */
4862                 else if ((*s == '?' || *s == '-' || *s == '+')
4863                          && !isSPACE(s[1]) && s[1] != '=')
4864                     PL_expect = XTERM;          /* e.g. print $fh -1 */
4865                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4866                          && s[1] != '/')
4867                     PL_expect = XTERM;          /* e.g. print $fh /.../
4868                                                    XXX except DORDOR operator
4869                                                 */
4870                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4871                          && s[2] != '=')
4872                     PL_expect = XTERM;          /* print $fh <<"EOF" */
4873             }
4874         }
4875         PL_pending_ident = '$';
4876         TOKEN('$');
4877
4878     case '@':
4879         if (PL_expect == XOPERATOR)
4880             no_op("Array", s);
4881         PL_tokenbuf[0] = '@';
4882         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4883         if (!PL_tokenbuf[1]) {
4884             PREREF('@');
4885         }
4886         if (PL_lex_state == LEX_NORMAL)
4887             s = SKIPSPACE1(s);
4888         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4889             if (*s == '{')
4890                 PL_tokenbuf[0] = '%';
4891
4892             /* Warn about @ where they meant $. */
4893             if (*s == '[' || *s == '{') {
4894                 if (ckWARN(WARN_SYNTAX)) {
4895                     const char *t = s + 1;
4896                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4897                         t++;
4898                     if (*t == '}' || *t == ']') {
4899                         t++;
4900                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4901                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4902                             "Scalar value %.*s better written as $%.*s",
4903                             (int)(t-PL_bufptr), PL_bufptr,
4904                             (int)(t-PL_bufptr-1), PL_bufptr+1);
4905                     }
4906                 }
4907             }
4908         }
4909         PL_pending_ident = '@';
4910         TERM('@');
4911
4912      case '/':                  /* may be division, defined-or, or pattern */
4913         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4914             s += 2;
4915             AOPERATOR(DORDOR);
4916         }
4917      case '?':                  /* may either be conditional or pattern */
4918          if(PL_expect == XOPERATOR) {
4919              char tmp = *s++;
4920              if(tmp == '?') {
4921                   OPERATOR('?');
4922              }
4923              else {
4924                  tmp = *s++;
4925                  if(tmp == '/') {
4926                      /* A // operator. */
4927                     AOPERATOR(DORDOR);
4928                  }
4929                  else {
4930                      s--;
4931                      Mop(OP_DIVIDE);
4932                  }
4933              }
4934          }
4935          else {
4936              /* Disable warning on "study /blah/" */
4937              if (PL_oldoldbufptr == PL_last_uni
4938               && (*PL_last_uni != 's' || s - PL_last_uni < 5
4939                   || memNE(PL_last_uni, "study", 5)
4940                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
4941               ))
4942                  check_uni();
4943              s = scan_pat(s,OP_MATCH);
4944              TERM(sublex_start());
4945          }
4946
4947     case '.':
4948         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4949 #ifdef PERL_STRICT_CR
4950             && s[1] == '\n'
4951 #else
4952             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4953 #endif
4954             && (s == PL_linestart || s[-1] == '\n') )
4955         {
4956             PL_lex_formbrack = 0;
4957             PL_expect = XSTATE;
4958             goto rightbracket;
4959         }
4960         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4961             char tmp = *s++;
4962             if (*s == tmp) {
4963                 s++;
4964                 if (*s == tmp) {
4965                     s++;
4966                     yylval.ival = OPf_SPECIAL;
4967                 }
4968                 else
4969                     yylval.ival = 0;
4970                 OPERATOR(DOTDOT);
4971             }
4972             if (PL_expect != XOPERATOR)
4973                 check_uni();
4974             Aop(OP_CONCAT);
4975         }
4976         /* FALL THROUGH */
4977     case '0': case '1': case '2': case '3': case '4':
4978     case '5': case '6': case '7': case '8': case '9':
4979         s = scan_num(s, &yylval);
4980         DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4981         if (PL_expect == XOPERATOR)
4982             no_op("Number",s);
4983         TERM(THING);
4984
4985     case '\'':
4986         s = scan_str(s,!!PL_madskills,FALSE);
4987         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4988         if (PL_expect == XOPERATOR) {
4989             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4990                 PL_expect = XTERM;
4991                 deprecate_old(commaless_variable_list);
4992                 return REPORT(','); /* grandfather non-comma-format format */
4993             }
4994             else
4995                 no_op("String",s);
4996         }
4997         if (!s)
4998             missingterm(NULL);
4999         yylval.ival = OP_CONST;
5000         TERM(sublex_start());
5001
5002     case '"':
5003         s = scan_str(s,!!PL_madskills,FALSE);
5004         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5005         if (PL_expect == XOPERATOR) {
5006             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5007                 PL_expect = XTERM;
5008                 deprecate_old(commaless_variable_list);
5009                 return REPORT(','); /* grandfather non-comma-format format */
5010             }
5011             else
5012                 no_op("String",s);
5013         }
5014         if (!s)
5015             missingterm(NULL);
5016         yylval.ival = OP_CONST;
5017         /* FIXME. I think that this can be const if char *d is replaced by
5018            more localised variables.  */
5019         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5020             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5021                 yylval.ival = OP_STRINGIFY;
5022                 break;
5023             }
5024         }
5025         TERM(sublex_start());
5026
5027     case '`':
5028         s = scan_str(s,!!PL_madskills,FALSE);
5029         DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5030         if (PL_expect == XOPERATOR)
5031             no_op("Backticks",s);
5032         if (!s)
5033             missingterm(NULL);
5034         readpipe_override();
5035         TERM(sublex_start());
5036
5037     case '\\':
5038         s++;
5039         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5040             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5041                         *s, *s);
5042         if (PL_expect == XOPERATOR)
5043             no_op("Backslash",s);
5044         OPERATOR(REFGEN);
5045
5046     case 'v':
5047         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5048             char *start = s + 2;
5049             while (isDIGIT(*start) || *start == '_')
5050                 start++;
5051             if (*start == '.' && isDIGIT(start[1])) {
5052                 s = scan_num(s, &yylval);
5053                 TERM(THING);
5054             }
5055             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5056             else if (!isALPHA(*start) && (PL_expect == XTERM
5057                         || PL_expect == XREF || PL_expect == XSTATE
5058                         || PL_expect == XTERMORDORDOR)) {
5059                 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5060                 const char c = *start;
5061                 GV *gv;
5062                 *start = '\0';
5063                 gv = gv_fetchpv(s, 0, SVt_PVCV);
5064                 *start = c;
5065                 if (!gv) {
5066                     s = scan_num(s, &yylval);
5067                     TERM(THING);
5068                 }
5069             }
5070         }
5071         goto keylookup;
5072     case 'x':
5073         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5074             s++;
5075             Mop(OP_REPEAT);
5076         }
5077         goto keylookup;
5078
5079     case '_':
5080     case 'a': case 'A':
5081     case 'b': case 'B':
5082     case 'c': case 'C':
5083     case 'd': case 'D':
5084     case 'e': case 'E':
5085     case 'f': case 'F':
5086     case 'g': case 'G':
5087     case 'h': case 'H':
5088     case 'i': case 'I':
5089     case 'j': case 'J':
5090     case 'k': case 'K':
5091     case 'l': case 'L':
5092     case 'm': case 'M':
5093     case 'n': case 'N':
5094     case 'o': case 'O':
5095     case 'p': case 'P':
5096     case 'q': case 'Q':
5097     case 'r': case 'R':
5098     case 's': case 'S':
5099     case 't': case 'T':
5100     case 'u': case 'U':
5101               case 'V':
5102     case 'w': case 'W':
5103               case 'X':
5104     case 'y': case 'Y':
5105     case 'z': case 'Z':
5106
5107       keylookup: {
5108         I32 tmp;
5109
5110         orig_keyword = 0;
5111         gv = NULL;
5112         gvp = NULL;
5113
5114         PL_bufptr = s;
5115         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5116
5117         /* Some keywords can be followed by any delimiter, including ':' */
5118         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5119                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5120                              (PL_tokenbuf[0] == 'q' &&
5121                               strchr("qwxr", PL_tokenbuf[1])))));
5122
5123         /* x::* is just a word, unless x is "CORE" */
5124         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5125             goto just_a_word;
5126
5127         d = s;
5128         while (d < PL_bufend && isSPACE(*d))
5129                 d++;    /* no comments skipped here, or s### is misparsed */
5130
5131         /* Is this a label? */
5132         if (!tmp && PL_expect == XSTATE
5133               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5134             s = d + 1;
5135             yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5136             CLINE;
5137             TOKEN(LABEL);
5138         }
5139
5140         /* Check for keywords */
5141         tmp = keyword(PL_tokenbuf, len, 0);
5142
5143         /* Is this a word before a => operator? */
5144         if (*d == '=' && d[1] == '>') {
5145             CLINE;
5146             yylval.opval
5147                 = (OP*)newSVOP(OP_CONST, 0,
5148                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5149             yylval.opval->op_private = OPpCONST_BARE;
5150             TERM(WORD);
5151         }
5152
5153         if (tmp < 0) {                  /* second-class keyword? */
5154             GV *ogv = NULL;     /* override (winner) */
5155             GV *hgv = NULL;     /* hidden (loser) */
5156             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5157                 CV *cv;
5158                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5159                     (cv = GvCVu(gv)))
5160                 {
5161                     if (GvIMPORTED_CV(gv))
5162                         ogv = gv;
5163                     else if (! CvMETHOD(cv))
5164                         hgv = gv;
5165                 }
5166                 if (!ogv &&
5167                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5168                     (gv = *gvp) != (GV*)&PL_sv_undef &&
5169                     GvCVu(gv) && GvIMPORTED_CV(gv))
5170                 {
5171                     ogv = gv;
5172                 }
5173             }
5174             if (ogv) {
5175                 orig_keyword = tmp;
5176                 tmp = 0;                /* overridden by import or by GLOBAL */
5177             }
5178             else if (gv && !gvp
5179                      && -tmp==KEY_lock  /* XXX generalizable kludge */
5180                      && GvCVu(gv)
5181                      && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5182             {
5183                 tmp = 0;                /* any sub overrides "weak" keyword */
5184             }
5185             else {                      /* no override */
5186                 tmp = -tmp;
5187                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5188                     Perl_warner(aTHX_ packWARN(WARN_MISC),
5189                             "dump() better written as CORE::dump()");
5190                 }
5191                 gv = NULL;
5192                 gvp = 0;
5193                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5194                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
5195                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5196                         "Ambiguous call resolved as CORE::%s(), %s",
5197                          GvENAME(hgv), "qualify as such or use &");
5198             }
5199         }
5200
5201       reserved_word:
5202         switch (tmp) {
5203
5204         default:                        /* not a keyword */
5205             /* Trade off - by using this evil construction we can pull the
5206                variable gv into the block labelled keylookup. If not, then
5207                we have to give it function scope so that the goto from the
5208                earlier ':' case doesn't bypass the initialisation.  */
5209             if (0) {
5210             just_a_word_zero_gv:
5211                 gv = NULL;
5212                 gvp = NULL;
5213                 orig_keyword = 0;
5214             }
5215           just_a_word: {
5216                 SV *sv;
5217                 int pkgname = 0;
5218                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5219                 CV *cv;
5220 #ifdef PERL_MAD
5221                 SV *nextPL_nextwhite = 0;
5222 #endif
5223
5224
5225                 /* Get the rest if it looks like a package qualifier */
5226
5227                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5228                     STRLEN morelen;
5229                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5230                                   TRUE, &morelen);
5231                     if (!morelen)
5232                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5233                                 *s == '\'' ? "'" : "::");
5234                     len += morelen;
5235                     pkgname = 1;
5236                 }
5237
5238                 if (PL_expect == XOPERATOR) {
5239                     if (PL_bufptr == PL_linestart) {
5240                         CopLINE_dec(PL_curcop);
5241                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5242                         CopLINE_inc(PL_curcop);
5243                     }
5244                     else
5245                         no_op("Bareword",s);
5246                 }
5247
5248                 /* Look for a subroutine with this name in current package,
5249                    unless name is "Foo::", in which case Foo is a bearword
5250                    (and a package name). */
5251
5252                 if (len > 2 && !PL_madskills &&
5253                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5254                 {
5255                     if (ckWARN(WARN_BAREWORD)
5256                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5257                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5258                             "Bareword \"%s\" refers to nonexistent package",
5259                              PL_tokenbuf);
5260                     len -= 2;
5261                     PL_tokenbuf[len] = '\0';
5262                     gv = NULL;
5263                     gvp = 0;
5264                 }
5265                 else {
5266                     if (!gv) {
5267                         /* Mustn't actually add anything to a symbol table.
5268                            But also don't want to "initialise" any placeholder
5269                            constants that might already be there into full
5270                            blown PVGVs with attached PVCV.  */
5271                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5272                                                GV_NOADD_NOINIT, SVt_PVCV);
5273                     }
5274                     len = 0;
5275                 }
5276
5277                 /* if we saw a global override before, get the right name */
5278
5279                 if (gvp) {
5280                     sv = newSVpvs("CORE::GLOBAL::");
5281                     sv_catpv(sv,PL_tokenbuf);
5282                 }
5283                 else {
5284                     /* If len is 0, newSVpv does strlen(), which is correct.
5285                        If len is non-zero, then it will be the true length,
5286                        and so the scalar will be created correctly.  */
5287                     sv = newSVpv(PL_tokenbuf,len);
5288                 }
5289 #ifdef PERL_MAD
5290                 if (PL_madskills && !PL_thistoken) {
5291                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5292                     PL_thistoken = newSVpv(start,s - start);
5293                     PL_realtokenstart = s - SvPVX(PL_linestr);
5294                 }
5295 #endif
5296
5297                 /* Presume this is going to be a bareword of some sort. */
5298
5299                 CLINE;
5300                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5301                 yylval.opval->op_private = OPpCONST_BARE;
5302                 /* UTF-8 package name? */
5303                 if (UTF && !IN_BYTES &&
5304                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5305                     SvUTF8_on(sv);
5306
5307                 /* And if "Foo::", then that's what it certainly is. */
5308
5309                 if (len)
5310                     goto safe_bareword;
5311
5312                 /* Do the explicit type check so that we don't need to force
5313                    the initialisation of the symbol table to have a real GV.
5314                    Beware - gv may not really be a PVGV, cv may not really be
5315                    a PVCV, (because of the space optimisations that gv_init
5316                    understands) But they're true if for this symbol there is
5317                    respectively a typeglob and a subroutine.
5318                 */
5319                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5320                     /* Real typeglob, so get the real subroutine: */
5321                            ? GvCVu(gv)
5322                     /* A proxy for a subroutine in this package? */
5323                            : SvOK(gv) ? (CV *) gv : NULL)
5324                     : NULL;
5325
5326                 /* See if it's the indirect object for a list operator. */
5327
5328                 if (PL_oldoldbufptr &&
5329                     PL_oldoldbufptr < PL_bufptr &&
5330                     (PL_oldoldbufptr == PL_last_lop
5331                      || PL_oldoldbufptr == PL_last_uni) &&
5332                     /* NO SKIPSPACE BEFORE HERE! */
5333                     (PL_expect == XREF ||
5334                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5335                 {
5336                     bool immediate_paren = *s == '(';
5337
5338                     /* (Now we can afford to cross potential line boundary.) */
5339                     s = SKIPSPACE2(s,nextPL_nextwhite);
5340 #ifdef PERL_MAD
5341                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5342 #endif
5343
5344                     /* Two barewords in a row may indicate method call. */
5345
5346                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5347                         (tmp = intuit_method(s, gv, cv)))
5348                         return REPORT(tmp);
5349
5350                     /* If not a declared subroutine, it's an indirect object. */
5351                     /* (But it's an indir obj regardless for sort.) */
5352                     /* Also, if "_" follows a filetest operator, it's a bareword */
5353
5354                     if (
5355                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5356                          ((!gv || !cv) &&
5357                         (PL_last_lop_op != OP_MAPSTART &&
5358                          PL_last_lop_op != OP_GREPSTART))))
5359                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5360                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5361                        )
5362                     {
5363                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5364                         goto bareword;
5365                     }
5366                 }
5367
5368                 PL_expect = XOPERATOR;
5369 #ifdef PERL_MAD
5370                 if (isSPACE(*s))
5371                     s = SKIPSPACE2(s,nextPL_nextwhite);
5372                 PL_nextwhite = nextPL_nextwhite;
5373 #else
5374                 s = skipspace(s);
5375 #endif
5376
5377                 /* Is this a word before a => operator? */
5378                 if (*s == '=' && s[1] == '>' && !pkgname) {
5379                     CLINE;
5380                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5381                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5382                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5383                     TERM(WORD);
5384                 }
5385
5386                 /* If followed by a paren, it's certainly a subroutine. */
5387                 if (*s == '(') {
5388                     CLINE;
5389                     if (cv) {
5390                         d = s + 1;
5391                         while (SPACE_OR_TAB(*d))
5392                             d++;
5393                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5394                             s = d + 1;
5395 #ifdef PERL_MAD
5396                             if (PL_madskills) {
5397                                 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5398                                 sv_catpvn(PL_thistoken, par, s - par);
5399                                 if (PL_nextwhite) {
5400                                     sv_free(PL_nextwhite);
5401                                     PL_nextwhite = 0;
5402                                 }
5403                             }
5404 #endif
5405                             goto its_constant;
5406                         }
5407                     }
5408 #ifdef PERL_MAD
5409                     if (PL_madskills) {
5410                         PL_nextwhite = PL_thiswhite;
5411                         PL_thiswhite = 0;
5412                     }
5413                     start_force(PL_curforce);
5414 #endif
5415                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5416                     PL_expect = XOPERATOR;
5417 #ifdef PERL_MAD
5418                     if (PL_madskills) {
5419                         PL_nextwhite = nextPL_nextwhite;
5420                         curmad('X', PL_thistoken);
5421                         PL_thistoken = newSVpvs("");
5422                     }
5423 #endif
5424                     force_next(WORD);
5425                     yylval.ival = 0;
5426                     TOKEN('&');
5427                 }
5428
5429                 /* If followed by var or block, call it a method (unless sub) */
5430
5431                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5432                     PL_last_lop = PL_oldbufptr;
5433                     PL_last_lop_op = OP_METHOD;
5434                     PREBLOCK(METHOD);
5435                 }
5436
5437                 /* If followed by a bareword, see if it looks like indir obj. */
5438
5439                 if (!orig_keyword
5440                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5441                         && (tmp = intuit_method(s, gv, cv)))
5442                     return REPORT(tmp);
5443
5444                 /* Not a method, so call it a subroutine (if defined) */
5445
5446                 if (cv) {
5447                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5448                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5449                                 "Ambiguous use of -%s resolved as -&%s()",
5450                                 PL_tokenbuf, PL_tokenbuf);
5451                     /* Check for a constant sub */
5452                     if ((sv = gv_const_sv(gv))) {
5453                   its_constant:
5454                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5455                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5456                         yylval.opval->op_private = 0;
5457                         TOKEN(WORD);
5458                     }
5459
5460                     /* Resolve to GV now. */
5461                     if (SvTYPE(gv) != SVt_PVGV) {
5462                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5463                         assert (SvTYPE(gv) == SVt_PVGV);
5464                         /* cv must have been some sort of placeholder, so
5465                            now needs replacing with a real code reference.  */
5466                         cv = GvCV(gv);
5467                     }
5468
5469                     op_free(yylval.opval);
5470                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5471                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5472                     PL_last_lop = PL_oldbufptr;
5473                     PL_last_lop_op = OP_ENTERSUB;
5474                     /* Is there a prototype? */
5475                     if (
5476 #ifdef PERL_MAD
5477                         cv &&
5478 #endif
5479                         SvPOK(cv))
5480                     {
5481                         STRLEN protolen;
5482                         const char *proto = SvPV_const((SV*)cv, protolen);
5483                         if (!protolen)
5484                             TERM(FUNC0SUB);
5485                         if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5486                             OPERATOR(UNIOPSUB);
5487                         while (*proto == ';')
5488                             proto++;
5489                         if (*proto == '&' && *s == '{') {
5490                             sv_setpv(PL_subname,
5491                                      (const char *)
5492                                      (PL_curstash ?
5493                                       "__ANON__" : "__ANON__::__ANON__"));
5494                             PREBLOCK(LSTOPSUB);
5495                         }
5496                     }
5497 #ifdef PERL_MAD
5498                     {
5499                         if (PL_madskills) {
5500                             PL_nextwhite = PL_thiswhite;
5501                             PL_thiswhite = 0;
5502                         }
5503                         start_force(PL_curforce);
5504                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5505                         PL_expect = XTERM;
5506                         if (PL_madskills) {
5507                             PL_nextwhite = nextPL_nextwhite;
5508                             curmad('X', PL_thistoken);
5509                             PL_thistoken = newSVpvs("");
5510                         }
5511                         force_next(WORD);
5512                         TOKEN(NOAMP);
5513                     }
5514                 }
5515
5516                 /* Guess harder when madskills require "best effort". */
5517                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5518                     int probable_sub = 0;
5519                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5520                         probable_sub = 1;
5521                     else if (isALPHA(*s)) {
5522                         char tmpbuf[1024];
5523                         STRLEN tmplen;
5524                         d = s;
5525                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5526                         if (!keyword(tmpbuf, tmplen, 0))
5527                             probable_sub = 1;
5528                         else {
5529                             while (d < PL_bufend && isSPACE(*d))
5530                                 d++;
5531                             if (*d == '=' && d[1] == '>')
5532                                 probable_sub = 1;
5533                         }
5534                     }
5535                     if (probable_sub) {
5536                         gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5537                         op_free(yylval.opval);
5538                         yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5539                         yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5540                         PL_last_lop = PL_oldbufptr;
5541                         PL_last_lop_op = OP_ENTERSUB;
5542                         PL_nextwhite = PL_thiswhite;
5543                         PL_thiswhite = 0;
5544                         start_force(PL_curforce);
5545                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5546                         PL_expect = XTERM;
5547                         PL_nextwhite = nextPL_nextwhite;
5548                         curmad('X', PL_thistoken);
5549                         PL_thistoken = newSVpvs("");
5550                         force_next(WORD);
5551                         TOKEN(NOAMP);
5552                     }
5553 #else
5554                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5555                     PL_expect = XTERM;
5556                     force_next(WORD);
5557                     TOKEN(NOAMP);
5558 #endif
5559                 }
5560
5561                 /* Call it a bare word */
5562
5563                 if (PL_hints & HINT_STRICT_SUBS)
5564                     yylval.opval->op_private |= OPpCONST_STRICT;
5565                 else {
5566                 bareword:
5567                     if (lastchar != '-') {
5568                         if (ckWARN(WARN_RESERVED)) {
5569                             d = PL_tokenbuf;
5570                             while (isLOWER(*d))
5571                                 d++;
5572                             if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5573                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5574                                        PL_tokenbuf);
5575                         }
5576                     }
5577                 }
5578
5579             safe_bareword:
5580                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5581                     && ckWARN_d(WARN_AMBIGUOUS)) {
5582                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5583                         "Operator or semicolon missing before %c%s",
5584                         lastchar, PL_tokenbuf);
5585                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5586                         "Ambiguous use of %c resolved as operator %c",
5587                         lastchar, lastchar);
5588                 }
5589                 TOKEN(WORD);
5590             }
5591
5592         case KEY___FILE__:
5593             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5594                                         newSVpv(CopFILE(PL_curcop),0));
5595             TERM(THING);
5596
5597         case KEY___LINE__:
5598             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5599                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5600             TERM(THING);
5601
5602         case KEY___PACKAGE__:
5603             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5604                                         (PL_curstash
5605                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5606                                          : &PL_sv_undef));
5607             TERM(THING);
5608
5609         case KEY___DATA__:
5610         case KEY___END__: {
5611             GV *gv;
5612             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5613                 const char *pname = "main";
5614                 if (PL_tokenbuf[2] == 'D')
5615                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5616                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5617                                 SVt_PVIO);
5618                 GvMULTI_on(gv);
5619                 if (!GvIO(gv))
5620                     GvIOp(gv) = newIO();
5621                 IoIFP(GvIOp(gv)) = PL_rsfp;
5622 #if defined(HAS_FCNTL) && defined(F_SETFD)
5623                 {
5624                     const int fd = PerlIO_fileno(PL_rsfp);
5625                     fcntl(fd,F_SETFD,fd >= 3);
5626                 }
5627 #endif
5628                 /* Mark this internal pseudo-handle as clean */
5629                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5630                 if (PL_preprocess)
5631                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5632                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5633                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5634                 else
5635                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5636 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5637                 /* if the script was opened in binmode, we need to revert
5638                  * it to text mode for compatibility; but only iff it has CRs
5639                  * XXX this is a questionable hack at best. */
5640                 if (PL_bufend-PL_bufptr > 2
5641                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5642                 {
5643                     Off_t loc = 0;
5644                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5645                         loc = PerlIO_tell(PL_rsfp);
5646                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5647                     }
5648 #ifdef NETWARE
5649                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5650 #else
5651                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5652 #endif  /* NETWARE */
5653 #ifdef PERLIO_IS_STDIO /* really? */
5654 #  if defined(__BORLANDC__)
5655                         /* XXX see note in do_binmode() */
5656                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5657 #  endif
5658 #endif
5659                         if (loc > 0)
5660                             PerlIO_seek(PL_rsfp, loc, 0);
5661                     }
5662                 }
5663 #endif
5664 #ifdef PERLIO_LAYERS
5665                 if (!IN_BYTES) {
5666                     if (UTF)
5667                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5668                     else if (PL_encoding) {
5669                         SV *name;
5670                         dSP;
5671                         ENTER;
5672                         SAVETMPS;
5673                         PUSHMARK(sp);
5674                         EXTEND(SP, 1);
5675                         XPUSHs(PL_encoding);
5676                         PUTBACK;
5677                         call_method("name", G_SCALAR);
5678                         SPAGAIN;
5679                         name = POPs;
5680                         PUTBACK;
5681                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5682                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5683                                                       SVfARG(name)));
5684                         FREETMPS;
5685                         LEAVE;
5686                     }
5687                 }
5688 #endif
5689 #ifdef PERL_MAD
5690                 if (PL_madskills) {
5691                     if (PL_realtokenstart >= 0) {
5692                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5693                         if (!PL_endwhite)
5694                             PL_endwhite = newSVpvs("");
5695                         sv_catsv(PL_endwhite, PL_thiswhite);
5696                         PL_thiswhite = 0;
5697                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5698                         PL_realtokenstart = -1;
5699                     }
5700                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5701                                  SvCUR(PL_endwhite))) != Nullch) ;
5702                 }
5703 #endif
5704                 PL_rsfp = NULL;
5705             }
5706             goto fake_eof;
5707         }
5708
5709         case KEY_AUTOLOAD:
5710         case KEY_DESTROY:
5711         case KEY_BEGIN:
5712         case KEY_UNITCHECK:
5713         case KEY_CHECK:
5714         case KEY_INIT:
5715         case KEY_END:
5716             if (PL_expect == XSTATE) {
5717                 s = PL_bufptr;
5718                 goto really_sub;
5719             }
5720             goto just_a_word;
5721
5722         case KEY_CORE:
5723             if (*s == ':' && s[1] == ':') {
5724                 s += 2;
5725                 d = s;
5726                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5727                 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5728                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5729                 if (tmp < 0)
5730                     tmp = -tmp;
5731                 else if (tmp == KEY_require || tmp == KEY_do)
5732                     /* that's a way to remember we saw "CORE::" */
5733                     orig_keyword = tmp;
5734                 goto reserved_word;
5735             }
5736             goto just_a_word;
5737
5738         case KEY_abs:
5739             UNI(OP_ABS);
5740
5741         case KEY_alarm:
5742             UNI(OP_ALARM);
5743
5744         case KEY_accept:
5745             LOP(OP_ACCEPT,XTERM);
5746
5747         case KEY_and:
5748             OPERATOR(ANDOP);
5749
5750         case KEY_atan2:
5751             LOP(OP_ATAN2,XTERM);
5752
5753         case KEY_bind:
5754             LOP(OP_BIND,XTERM);
5755
5756         case KEY_binmode:
5757             LOP(OP_BINMODE,XTERM);
5758
5759         case KEY_bless:
5760             LOP(OP_BLESS,XTERM);
5761
5762         case KEY_break:
5763             FUN0(OP_BREAK);
5764
5765         case KEY_chop:
5766             UNI(OP_CHOP);
5767
5768         case KEY_continue:
5769             /* When 'use switch' is in effect, continue has a dual
5770                life as a control operator. */
5771             {
5772                 if (!FEATURE_IS_ENABLED("switch"))
5773                     PREBLOCK(CONTINUE);
5774                 else {
5775                     /* We have to disambiguate the two senses of
5776                       "continue". If the next token is a '{' then
5777                       treat it as the start of a continue block;
5778                       otherwise treat it as a control operator.
5779                      */
5780                     s = skipspace(s);
5781                     if (*s == '{')
5782             PREBLOCK(CONTINUE);
5783                     else
5784                         FUN0(OP_CONTINUE);
5785                 }
5786             }
5787
5788         case KEY_chdir:
5789             /* may use HOME */
5790             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5791             UNI(OP_CHDIR);
5792
5793         case KEY_close:
5794             UNI(OP_CLOSE);
5795
5796         case KEY_closedir:
5797             UNI(OP_CLOSEDIR);
5798
5799         case KEY_cmp:
5800             Eop(OP_SCMP);
5801
5802         case KEY_caller:
5803             UNI(OP_CALLER);
5804
5805         case KEY_crypt:
5806 #ifdef FCRYPT
5807             if (!PL_cryptseen) {
5808                 PL_cryptseen = TRUE;
5809                 init_des();
5810             }
5811 #endif
5812             LOP(OP_CRYPT,XTERM);
5813
5814         case KEY_chmod:
5815             LOP(OP_CHMOD,XTERM);
5816
5817         case KEY_chown:
5818             LOP(OP_CHOWN,XTERM);
5819
5820         case KEY_connect:
5821             LOP(OP_CONNECT,XTERM);
5822
5823         case KEY_chr:
5824             UNI(OP_CHR);
5825
5826         case KEY_cos:
5827             UNI(OP_COS);
5828
5829         case KEY_chroot:
5830             UNI(OP_CHROOT);
5831
5832         case KEY_default:
5833             PREBLOCK(DEFAULT);
5834
5835         case KEY_do:
5836             s = SKIPSPACE1(s);
5837             if (*s == '{')
5838                 PRETERMBLOCK(DO);
5839             if (*s != '\'')
5840                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5841             if (orig_keyword == KEY_do) {
5842                 orig_keyword = 0;
5843                 yylval.ival = 1;
5844             }
5845             else
5846                 yylval.ival = 0;
5847             OPERATOR(DO);
5848
5849         case KEY_die:
5850             PL_hints |= HINT_BLOCK_SCOPE;
5851             LOP(OP_DIE,XTERM);
5852
5853         case KEY_defined:
5854             UNI(OP_DEFINED);
5855
5856         case KEY_delete:
5857             UNI(OP_DELETE);
5858
5859         case KEY_dbmopen:
5860             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5861             LOP(OP_DBMOPEN,XTERM);
5862
5863         case KEY_dbmclose:
5864             UNI(OP_DBMCLOSE);
5865
5866         case KEY_dump:
5867             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5868             LOOPX(OP_DUMP);
5869
5870         case KEY_else:
5871             PREBLOCK(ELSE);
5872
5873         case KEY_elsif:
5874             yylval.ival = CopLINE(PL_curcop);
5875             OPERATOR(ELSIF);
5876
5877         case KEY_eq:
5878             Eop(OP_SEQ);
5879
5880         case KEY_exists:
5881             UNI(OP_EXISTS);
5882
5883         case KEY_exit:
5884             if (PL_madskills)
5885                 UNI(OP_INT);
5886             UNI(OP_EXIT);
5887
5888         case KEY_eval:
5889             s = SKIPSPACE1(s);
5890             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5891             UNIBRACK(OP_ENTEREVAL);
5892
5893         case KEY_eof:
5894             UNI(OP_EOF);
5895
5896         case KEY_err:
5897             OPERATOR(DOROP);
5898
5899         case KEY_exp:
5900             UNI(OP_EXP);
5901
5902         case KEY_each:
5903             UNI(OP_EACH);
5904
5905         case KEY_exec:
5906             set_csh();
5907             LOP(OP_EXEC,XREF);
5908
5909         case KEY_endhostent:
5910             FUN0(OP_EHOSTENT);
5911
5912         case KEY_endnetent:
5913             FUN0(OP_ENETENT);
5914
5915         case KEY_endservent:
5916             FUN0(OP_ESERVENT);
5917
5918         case KEY_endprotoent:
5919             FUN0(OP_EPROTOENT);
5920
5921         case KEY_endpwent:
5922             FUN0(OP_EPWENT);
5923
5924         case KEY_endgrent:
5925             FUN0(OP_EGRENT);
5926
5927         case KEY_for:
5928         case KEY_foreach:
5929             yylval.ival = CopLINE(PL_curcop);
5930             s = SKIPSPACE1(s);
5931             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5932                 char *p = s;
5933 #ifdef PERL_MAD
5934                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5935 #endif
5936
5937                 if ((PL_bufend - p) >= 3 &&
5938                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5939                     p += 2;
5940                 else if ((PL_bufend - p) >= 4 &&
5941                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5942                     p += 3;
5943                 p = PEEKSPACE(p);
5944                 if (isIDFIRST_lazy_if(p,UTF)) {
5945                     p = scan_ident(p, PL_bufend,
5946                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5947                     p = PEEKSPACE(p);
5948                 }
5949                 if (*p != '$')
5950                     Perl_croak(aTHX_ "Missing $ on loop variable");
5951 #ifdef PERL_MAD
5952                 s = SvPVX(PL_linestr) + soff;
5953 #endif
5954             }
5955             OPERATOR(FOR);
5956
5957         case KEY_formline:
5958             LOP(OP_FORMLINE,XTERM);
5959
5960         case KEY_fork:
5961             FUN0(OP_FORK);
5962
5963         case KEY_fcntl:
5964             LOP(OP_FCNTL,XTERM);
5965
5966         case KEY_fileno:
5967             UNI(OP_FILENO);
5968
5969         case KEY_flock:
5970             LOP(OP_FLOCK,XTERM);
5971
5972         case KEY_gt:
5973             Rop(OP_SGT);
5974
5975         case KEY_ge:
5976             Rop(OP_SGE);
5977
5978         case KEY_grep:
5979             LOP(OP_GREPSTART, XREF);
5980
5981         case KEY_goto:
5982             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5983             LOOPX(OP_GOTO);
5984
5985         case KEY_gmtime:
5986             UNI(OP_GMTIME);
5987
5988         case KEY_getc:
5989             UNIDOR(OP_GETC);
5990
5991         case KEY_getppid:
5992             FUN0(OP_GETPPID);
5993
5994         case KEY_getpgrp:
5995             UNI(OP_GETPGRP);
5996
5997         case KEY_getpriority:
5998             LOP(OP_GETPRIORITY,XTERM);
5999
6000         case KEY_getprotobyname:
6001             UNI(OP_GPBYNAME);
6002
6003         case KEY_getprotobynumber:
6004             LOP(OP_GPBYNUMBER,XTERM);
6005
6006         case KEY_getprotoent:
6007             FUN0(OP_GPROTOENT);
6008
6009         case KEY_getpwent:
6010             FUN0(OP_GPWENT);
6011
6012         case KEY_getpwnam:
6013             UNI(OP_GPWNAM);
6014
6015         case KEY_getpwuid:
6016             UNI(OP_GPWUID);
6017
6018         case KEY_getpeername:
6019             UNI(OP_GETPEERNAME);
6020
6021         case KEY_gethostbyname:
6022             UNI(OP_GHBYNAME);
6023
6024         case KEY_gethostbyaddr:
6025             LOP(OP_GHBYADDR,XTERM);
6026
6027         case KEY_gethostent:
6028             FUN0(OP_GHOSTENT);
6029
6030         case KEY_getnetbyname:
6031             UNI(OP_GNBYNAME);
6032
6033         case KEY_getnetbyaddr:
6034             LOP(OP_GNBYADDR,XTERM);
6035
6036         case KEY_getnetent:
6037             FUN0(OP_GNETENT);
6038
6039         case KEY_getservbyname:
6040             LOP(OP_GSBYNAME,XTERM);
6041
6042         case KEY_getservbyport:
6043             LOP(OP_GSBYPORT,XTERM);
6044
6045         case KEY_getservent:
6046             FUN0(OP_GSERVENT);
6047
6048         case KEY_getsockname:
6049             UNI(OP_GETSOCKNAME);
6050
6051         case KEY_getsockopt:
6052             LOP(OP_GSOCKOPT,XTERM);
6053
6054         case KEY_getgrent:
6055             FUN0(OP_GGRENT);
6056
6057         case KEY_getgrnam:
6058             UNI(OP_GGRNAM);
6059
6060         case KEY_getgrgid:
6061             UNI(OP_GGRGID);
6062
6063         case KEY_getlogin:
6064             FUN0(OP_GETLOGIN);
6065
6066         case KEY_given:
6067             yylval.ival = CopLINE(PL_curcop);
6068             OPERATOR(GIVEN);
6069
6070         case KEY_glob:
6071             set_csh();
6072             LOP(OP_GLOB,XTERM);
6073
6074         case KEY_hex:
6075             UNI(OP_HEX);
6076
6077         case KEY_if:
6078             yylval.ival = CopLINE(PL_curcop);
6079             OPERATOR(IF);
6080
6081         case KEY_index:
6082             LOP(OP_INDEX,XTERM);
6083
6084         case KEY_int:
6085             UNI(OP_INT);
6086
6087         case KEY_ioctl:
6088             LOP(OP_IOCTL,XTERM);
6089
6090         case KEY_join:
6091             LOP(OP_JOIN,XTERM);
6092
6093         case KEY_keys:
6094             UNI(OP_KEYS);
6095
6096         case KEY_kill:
6097             LOP(OP_KILL,XTERM);
6098
6099         case KEY_last:
6100             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6101             LOOPX(OP_LAST);
6102
6103         case KEY_lc:
6104             UNI(OP_LC);
6105
6106         case KEY_lcfirst:
6107             UNI(OP_LCFIRST);
6108
6109         case KEY_local:
6110             yylval.ival = 0;
6111             OPERATOR(LOCAL);
6112
6113         case KEY_length:
6114             UNI(OP_LENGTH);
6115
6116         case KEY_lt:
6117             Rop(OP_SLT);
6118
6119         case KEY_le:
6120             Rop(OP_SLE);
6121
6122         case KEY_localtime:
6123             UNI(OP_LOCALTIME);
6124
6125         case KEY_log:
6126             UNI(OP_LOG);
6127
6128         case KEY_link:
6129             LOP(OP_LINK,XTERM);
6130
6131         case KEY_listen:
6132             LOP(OP_LISTEN,XTERM);
6133
6134         case KEY_lock:
6135             UNI(OP_LOCK);
6136
6137         case KEY_lstat:
6138             UNI(OP_LSTAT);
6139
6140         case KEY_m:
6141             s = scan_pat(s,OP_MATCH);
6142             TERM(sublex_start());
6143
6144         case KEY_map:
6145             LOP(OP_MAPSTART, XREF);
6146
6147         case KEY_mkdir:
6148             LOP(OP_MKDIR,XTERM);
6149
6150         case KEY_msgctl:
6151             LOP(OP_MSGCTL,XTERM);
6152
6153         case KEY_msgget:
6154             LOP(OP_MSGGET,XTERM);
6155
6156         case KEY_msgrcv:
6157             LOP(OP_MSGRCV,XTERM);
6158
6159         case KEY_msgsnd:
6160             LOP(OP_MSGSND,XTERM);
6161
6162         case KEY_our:
6163         case KEY_my:
6164         case KEY_state:
6165             PL_in_my = tmp;
6166             s = SKIPSPACE1(s);
6167             if (isIDFIRST_lazy_if(s,UTF)) {
6168 #ifdef PERL_MAD
6169                 char* start = s;
6170 #endif
6171                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6172                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6173                     goto really_sub;
6174                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6175                 if (!PL_in_my_stash) {
6176                     char tmpbuf[1024];
6177                     PL_bufptr = s;
6178                     my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6179                     yyerror(tmpbuf);
6180                 }
6181 #ifdef PERL_MAD
6182                 if (PL_madskills) {     /* just add type to declarator token */
6183                     sv_catsv(PL_thistoken, PL_nextwhite);
6184                     PL_nextwhite = 0;
6185                     sv_catpvn(PL_thistoken, start, s - start);
6186                 }
6187 #endif
6188             }
6189             yylval.ival = 1;
6190             OPERATOR(MY);
6191
6192         case KEY_next:
6193             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6194             LOOPX(OP_NEXT);
6195
6196         case KEY_ne:
6197             Eop(OP_SNE);
6198
6199         case KEY_no:
6200             s = tokenize_use(0, s);
6201             OPERATOR(USE);
6202
6203         case KEY_not:
6204             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6205                 FUN1(OP_NOT);
6206             else
6207                 OPERATOR(NOTOP);
6208
6209         case KEY_open:
6210             s = SKIPSPACE1(s);
6211             if (isIDFIRST_lazy_if(s,UTF)) {
6212                 const char *t;
6213                 for (d = s; isALNUM_lazy_if(d,UTF);)
6214                     d++;
6215                 for (t=d; isSPACE(*t);)
6216                     t++;
6217                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6218                     /* [perl #16184] */
6219                     && !(t[0] == '=' && t[1] == '>')
6220                 ) {
6221                     int parms_len = (int)(d-s);
6222                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6223                            "Precedence problem: open %.*s should be open(%.*s)",
6224                             parms_len, s, parms_len, s);
6225                 }
6226             }
6227             LOP(OP_OPEN,XTERM);
6228
6229         case KEY_or:
6230             yylval.ival = OP_OR;
6231             OPERATOR(OROP);
6232
6233         case KEY_ord:
6234             UNI(OP_ORD);
6235
6236         case KEY_oct:
6237             UNI(OP_OCT);
6238
6239         case KEY_opendir:
6240             LOP(OP_OPEN_DIR,XTERM);
6241
6242         case KEY_print:
6243             checkcomma(s,PL_tokenbuf,"filehandle");
6244             LOP(OP_PRINT,XREF);
6245
6246         case KEY_printf:
6247             checkcomma(s,PL_tokenbuf,"filehandle");
6248             LOP(OP_PRTF,XREF);
6249
6250         case KEY_prototype:
6251             UNI(OP_PROTOTYPE);
6252
6253         case KEY_push:
6254             LOP(OP_PUSH,XTERM);
6255
6256         case KEY_pop:
6257             UNIDOR(OP_POP);
6258
6259         case KEY_pos:
6260             UNIDOR(OP_POS);
6261
6262         case KEY_pack:
6263             LOP(OP_PACK,XTERM);
6264
6265         case KEY_package:
6266             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6267             OPERATOR(PACKAGE);
6268
6269         case KEY_pipe:
6270             LOP(OP_PIPE_OP,XTERM);
6271
6272         case KEY_q:
6273             s = scan_str(s,!!PL_madskills,FALSE);
6274             if (!s)
6275                 missingterm(NULL);
6276             yylval.ival = OP_CONST;
6277             TERM(sublex_start());
6278
6279         case KEY_quotemeta:
6280             UNI(OP_QUOTEMETA);
6281
6282         case KEY_qw:
6283             s = scan_str(s,!!PL_madskills,FALSE);
6284             if (!s)
6285                 missingterm(NULL);
6286             PL_expect = XOPERATOR;
6287             force_next(')');
6288             if (SvCUR(PL_lex_stuff)) {
6289                 OP *words = NULL;
6290                 int warned = 0;
6291                 d = SvPV_force(PL_lex_stuff, len);
6292                 while (len) {
6293                     for (; isSPACE(*d) && len; --len, ++d)
6294                         /**/;
6295                     if (len) {
6296                         SV *sv;
6297                         const char *b = d;
6298                         if (!warned && ckWARN(WARN_QW)) {
6299                             for (; !isSPACE(*d) && len; --len, ++d) {
6300                                 if (*d == ',') {
6301                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6302                                         "Possible attempt to separate words with commas");
6303                                     ++warned;
6304                                 }
6305                                 else if (*d == '#') {
6306                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6307                                         "Possible attempt to put comments in qw() list");
6308                                     ++warned;
6309                                 }
6310                             }
6311                         }
6312                         else {
6313                             for (; !isSPACE(*d) && len; --len, ++d)
6314                                 /**/;
6315                         }
6316                         sv = newSVpvn(b, d-b);
6317                         if (DO_UTF8(PL_lex_stuff))
6318                             SvUTF8_on(sv);
6319                         words = append_elem(OP_LIST, words,
6320                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6321                     }
6322                 }
6323                 if (words) {
6324                     start_force(PL_curforce);
6325                     NEXTVAL_NEXTTOKE.opval = words;
6326                     force_next(THING);
6327                 }
6328             }
6329             if (PL_lex_stuff) {
6330                 SvREFCNT_dec(PL_lex_stuff);
6331                 PL_lex_stuff = NULL;
6332             }
6333             PL_expect = XTERM;
6334             TOKEN('(');
6335
6336         case KEY_qq:
6337             s = scan_str(s,!!PL_madskills,FALSE);
6338             if (!s)
6339                 missingterm(NULL);
6340             yylval.ival = OP_STRINGIFY;
6341             if (SvIVX(PL_lex_stuff) == '\'')
6342                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6343             TERM(sublex_start());
6344
6345         case KEY_qr:
6346             s = scan_pat(s,OP_QR);
6347             TERM(sublex_start());
6348
6349         case KEY_qx:
6350             s = scan_str(s,!!PL_madskills,FALSE);
6351             if (!s)
6352                 missingterm(NULL);
6353             readpipe_override();
6354             TERM(sublex_start());
6355
6356         case KEY_return:
6357             OLDLOP(OP_RETURN);
6358
6359         case KEY_require:
6360             s = SKIPSPACE1(s);
6361             if (isDIGIT(*s)) {
6362                 s = force_version(s, FALSE);
6363             }
6364             else if (*s != 'v' || !isDIGIT(s[1])
6365                     || (s = force_version(s, TRUE), *s == 'v'))
6366             {
6367                 *PL_tokenbuf = '\0';
6368                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6369                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6370                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6371                 else if (*s == '<')
6372                     yyerror("<> should be quotes");
6373             }
6374             if (orig_keyword == KEY_require) {
6375                 orig_keyword = 0;
6376                 yylval.ival = 1;
6377             }
6378             else
6379                 yylval.ival = 0;
6380             PL_expect = XTERM;
6381             PL_bufptr = s;
6382             PL_last_uni = PL_oldbufptr;
6383             PL_last_lop_op = OP_REQUIRE;
6384             s = skipspace(s);
6385             return REPORT( (int)REQUIRE );
6386
6387         case KEY_reset:
6388             UNI(OP_RESET);
6389
6390         case KEY_redo:
6391             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6392             LOOPX(OP_REDO);
6393
6394         case KEY_rename:
6395             LOP(OP_RENAME,XTERM);
6396
6397         case KEY_rand:
6398             UNI(OP_RAND);
6399
6400         case KEY_rmdir:
6401             UNI(OP_RMDIR);
6402
6403         case KEY_rindex:
6404             LOP(OP_RINDEX,XTERM);
6405
6406         case KEY_read:
6407             LOP(OP_READ,XTERM);
6408
6409         case KEY_readdir:
6410             UNI(OP_READDIR);
6411
6412         case KEY_readline:
6413             set_csh();
6414             UNIDOR(OP_READLINE);
6415
6416         case KEY_readpipe:
6417             set_csh();
6418             UNI(OP_BACKTICK);
6419
6420         case KEY_rewinddir:
6421             UNI(OP_REWINDDIR);
6422
6423         case KEY_recv:
6424             LOP(OP_RECV,XTERM);
6425
6426         case KEY_reverse:
6427             LOP(OP_REVERSE,XTERM);
6428
6429         case KEY_readlink:
6430             UNIDOR(OP_READLINK);
6431
6432         case KEY_ref:
6433             UNI(OP_REF);
6434
6435         case KEY_s:
6436             s = scan_subst(s);
6437             if (yylval.opval)
6438                 TERM(sublex_start());
6439             else
6440                 TOKEN(1);       /* force error */
6441
6442         case KEY_say:
6443             checkcomma(s,PL_tokenbuf,"filehandle");
6444             LOP(OP_SAY,XREF);
6445
6446         case KEY_chomp:
6447             UNI(OP_CHOMP);
6448
6449         case KEY_scalar:
6450             UNI(OP_SCALAR);
6451
6452         case KEY_select:
6453             LOP(OP_SELECT,XTERM);
6454
6455         case KEY_seek:
6456             LOP(OP_SEEK,XTERM);
6457
6458         case KEY_semctl:
6459             LOP(OP_SEMCTL,XTERM);
6460
6461         case KEY_semget:
6462             LOP(OP_SEMGET,XTERM);
6463
6464         case KEY_semop:
6465             LOP(OP_SEMOP,XTERM);
6466
6467         case KEY_send:
6468             LOP(OP_SEND,XTERM);
6469
6470         case KEY_setpgrp:
6471             LOP(OP_SETPGRP,XTERM);
6472
6473         case KEY_setpriority:
6474             LOP(OP_SETPRIORITY,XTERM);
6475
6476         case KEY_sethostent:
6477             UNI(OP_SHOSTENT);
6478
6479         case KEY_setnetent:
6480             UNI(OP_SNETENT);
6481
6482         case KEY_setservent:
6483             UNI(OP_SSERVENT);
6484
6485         case KEY_setprotoent:
6486             UNI(OP_SPROTOENT);
6487
6488         case KEY_setpwent:
6489             FUN0(OP_SPWENT);
6490
6491         case KEY_setgrent:
6492             FUN0(OP_SGRENT);
6493
6494         case KEY_seekdir:
6495             LOP(OP_SEEKDIR,XTERM);
6496
6497         case KEY_setsockopt:
6498             LOP(OP_SSOCKOPT,XTERM);
6499
6500         case KEY_shift:
6501             UNIDOR(OP_SHIFT);
6502
6503         case KEY_shmctl:
6504             LOP(OP_SHMCTL,XTERM);
6505
6506         case KEY_shmget:
6507             LOP(OP_SHMGET,XTERM);
6508
6509         case KEY_shmread:
6510             LOP(OP_SHMREAD,XTERM);
6511
6512         case KEY_shmwrite:
6513             LOP(OP_SHMWRITE,XTERM);
6514
6515         case KEY_shutdown:
6516             LOP(OP_SHUTDOWN,XTERM);
6517
6518         case KEY_sin:
6519             UNI(OP_SIN);
6520
6521         case KEY_sleep:
6522             UNI(OP_SLEEP);
6523
6524         case KEY_socket:
6525             LOP(OP_SOCKET,XTERM);
6526
6527         case KEY_socketpair:
6528             LOP(OP_SOCKPAIR,XTERM);
6529
6530         case KEY_sort:
6531             checkcomma(s,PL_tokenbuf,"subroutine name");
6532             s = SKIPSPACE1(s);
6533             if (*s == ';' || *s == ')')         /* probably a close */
6534                 Perl_croak(aTHX_ "sort is now a reserved word");
6535             PL_expect = XTERM;
6536             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6537             LOP(OP_SORT,XREF);
6538
6539         case KEY_split:
6540             LOP(OP_SPLIT,XTERM);
6541
6542         case KEY_sprintf:
6543             LOP(OP_SPRINTF,XTERM);
6544
6545         case KEY_splice:
6546             LOP(OP_SPLICE,XTERM);
6547
6548         case KEY_sqrt:
6549             UNI(OP_SQRT);
6550
6551         case KEY_srand:
6552             UNI(OP_SRAND);
6553
6554         case KEY_stat:
6555             UNI(OP_STAT);
6556
6557         case KEY_study:
6558             UNI(OP_STUDY);
6559
6560         case KEY_substr:
6561             LOP(OP_SUBSTR,XTERM);
6562
6563         case KEY_format:
6564         case KEY_sub:
6565           really_sub:
6566             {
6567                 char tmpbuf[sizeof PL_tokenbuf];
6568                 SSize_t tboffset = 0;
6569                 expectation attrful;
6570                 bool have_name, have_proto;
6571                 const int key = tmp;
6572
6573 #ifdef PERL_MAD
6574                 SV *tmpwhite = 0;
6575
6576                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6577                 SV *subtoken = newSVpvn(tstart, s - tstart);
6578                 PL_thistoken = 0;
6579
6580                 d = s;
6581                 s = SKIPSPACE2(s,tmpwhite);
6582 #else
6583                 s = skipspace(s);
6584 #endif
6585
6586                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6587                     (*s == ':' && s[1] == ':'))
6588                 {
6589 #ifdef PERL_MAD
6590                     SV *nametoke;
6591 #endif
6592
6593                     PL_expect = XBLOCK;
6594                     attrful = XATTRBLOCK;
6595                     /* remember buffer pos'n for later force_word */
6596                     tboffset = s - PL_oldbufptr;
6597                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6598 #ifdef PERL_MAD
6599                     if (PL_madskills)
6600                         nametoke = newSVpvn(s, d - s);
6601 #endif
6602                     if (strchr(tmpbuf, ':'))
6603                         sv_setpv(PL_subname, tmpbuf);
6604                     else {
6605                         sv_setsv(PL_subname,PL_curstname);
6606                         sv_catpvs(PL_subname,"::");
6607                         sv_catpvn(PL_subname,tmpbuf,len);
6608                     }
6609                     have_name = TRUE;
6610
6611 #ifdef PERL_MAD
6612
6613                     start_force(0);
6614                     CURMAD('X', nametoke);
6615                     CURMAD('_', tmpwhite);
6616                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6617                                       FALSE, TRUE, TRUE);
6618
6619                     s = SKIPSPACE2(d,tmpwhite);
6620 #else
6621                     s = skipspace(d);
6622 #endif
6623                 }
6624                 else {
6625                     if (key == KEY_my)
6626                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6627                     PL_expect = XTERMBLOCK;
6628                     attrful = XATTRTERM;
6629                     sv_setpvn(PL_subname,"?",1);
6630                     have_name = FALSE;
6631                 }
6632
6633                 if (key == KEY_format) {
6634                     if (*s == '=')
6635                         PL_lex_formbrack = PL_lex_brackets + 1;
6636 #ifdef PERL_MAD
6637                     PL_thistoken = subtoken;
6638                     s = d;
6639 #else
6640                     if (have_name)
6641                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6642                                           FALSE, TRUE, TRUE);
6643 #endif
6644                     OPERATOR(FORMAT);
6645                 }
6646
6647                 /* Look for a prototype */
6648                 if (*s == '(') {
6649                     char *p;
6650                     bool bad_proto = FALSE;
6651                     const bool warnsyntax = ckWARN(WARN_SYNTAX);
6652
6653                     s = scan_str(s,!!PL_madskills,FALSE);
6654                     if (!s)
6655                         Perl_croak(aTHX_ "Prototype not terminated");
6656                     /* strip spaces and check for bad characters */
6657                     d = SvPVX(PL_lex_stuff);
6658                     tmp = 0;
6659                     for (p = d; *p; ++p) {
6660                         if (!isSPACE(*p)) {
6661                             d[tmp++] = *p;
6662                             if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6663                                 bad_proto = TRUE;
6664                         }
6665                     }
6666                     d[tmp] = '\0';
6667                     if (bad_proto)
6668                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6669                                     "Illegal character in prototype for %"SVf" : %s",
6670                                     SVfARG(PL_subname), d);
6671                     SvCUR_set(PL_lex_stuff, tmp);
6672                     have_proto = TRUE;
6673
6674 #ifdef PERL_MAD
6675                     start_force(0);
6676                     CURMAD('q', PL_thisopen);
6677                     CURMAD('_', tmpwhite);
6678                     CURMAD('=', PL_thisstuff);
6679                     CURMAD('Q', PL_thisclose);
6680                     NEXTVAL_NEXTTOKE.opval =
6681                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6682                     PL_lex_stuff = Nullsv;
6683                     force_next(THING);
6684
6685                     s = SKIPSPACE2(s,tmpwhite);
6686 #else
6687                     s = skipspace(s);
6688 #endif
6689                 }
6690                 else
6691                     have_proto = FALSE;
6692
6693                 if (*s == ':' && s[1] != ':')
6694                     PL_expect = attrful;
6695                 else if (*s != '{' && key == KEY_sub) {
6696                     if (!have_name)
6697                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6698                     else if (*s != ';')
6699                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6700                 }
6701
6702 #ifdef PERL_MAD
6703                 start_force(0);
6704                 if (tmpwhite) {
6705                     if (PL_madskills)
6706                         curmad('^', newSVpvs(""));
6707                     CURMAD('_', tmpwhite);
6708                 }
6709                 force_next(0);
6710
6711                 PL_thistoken = subtoken;
6712 #else
6713                 if (have_proto) {
6714                     NEXTVAL_NEXTTOKE.opval =
6715                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6716                     PL_lex_stuff = NULL;
6717                     force_next(THING);
6718                 }
6719 #endif
6720                 if (!have_name) {
6721                     sv_setpv(PL_subname,
6722                              (const char *)
6723                              (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6724                     TOKEN(ANONSUB);
6725                 }
6726 #ifndef PERL_MAD
6727                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6728                                   FALSE, TRUE, TRUE);
6729 #endif
6730                 if (key == KEY_my)
6731                     TOKEN(MYSUB);
6732                 TOKEN(SUB);
6733             }
6734
6735         case KEY_system:
6736             set_csh();
6737             LOP(OP_SYSTEM,XREF);
6738
6739         case KEY_symlink:
6740             LOP(OP_SYMLINK,XTERM);
6741
6742         case KEY_syscall:
6743             LOP(OP_SYSCALL,XTERM);
6744
6745         case KEY_sysopen:
6746             LOP(OP_SYSOPEN,XTERM);
6747
6748         case KEY_sysseek:
6749             LOP(OP_SYSSEEK,XTERM);
6750
6751         case KEY_sysread:
6752             LOP(OP_SYSREAD,XTERM);
6753
6754         case KEY_syswrite:
6755             LOP(OP_SYSWRITE,XTERM);
6756
6757         case KEY_tr:
6758             s = scan_trans(s);
6759             TERM(sublex_start());
6760
6761         case KEY_tell:
6762             UNI(OP_TELL);
6763
6764         case KEY_telldir:
6765             UNI(OP_TELLDIR);
6766
6767         case KEY_tie:
6768             LOP(OP_TIE,XTERM);
6769
6770         case KEY_tied:
6771             UNI(OP_TIED);
6772
6773         case KEY_time:
6774             FUN0(OP_TIME);
6775
6776         case KEY_times:
6777             FUN0(OP_TMS);
6778
6779         case KEY_truncate:
6780             LOP(OP_TRUNCATE,XTERM);
6781
6782         case KEY_uc:
6783             UNI(OP_UC);
6784
6785         case KEY_ucfirst:
6786             UNI(OP_UCFIRST);
6787
6788         case KEY_untie:
6789             UNI(OP_UNTIE);
6790
6791         case KEY_until:
6792             yylval.ival = CopLINE(PL_curcop);
6793             OPERATOR(UNTIL);
6794
6795         case KEY_unless:
6796             yylval.ival = CopLINE(PL_curcop);
6797             OPERATOR(UNLESS);
6798
6799         case KEY_unlink:
6800             LOP(OP_UNLINK,XTERM);
6801
6802         case KEY_undef:
6803             UNIDOR(OP_UNDEF);
6804
6805         case KEY_unpack:
6806             LOP(OP_UNPACK,XTERM);
6807
6808         case KEY_utime:
6809             LOP(OP_UTIME,XTERM);
6810
6811         case KEY_umask:
6812             UNIDOR(OP_UMASK);
6813
6814         case KEY_unshift:
6815             LOP(OP_UNSHIFT,XTERM);
6816
6817         case KEY_use:
6818             s = tokenize_use(1, s);
6819             OPERATOR(USE);
6820
6821         case KEY_values:
6822             UNI(OP_VALUES);
6823
6824         case KEY_vec:
6825             LOP(OP_VEC,XTERM);
6826
6827         case KEY_when:
6828             yylval.ival = CopLINE(PL_curcop);
6829             OPERATOR(WHEN);
6830
6831         case KEY_while:
6832             yylval.ival = CopLINE(PL_curcop);
6833             OPERATOR(WHILE);
6834
6835         case KEY_warn:
6836             PL_hints |= HINT_BLOCK_SCOPE;
6837             LOP(OP_WARN,XTERM);
6838
6839         case KEY_wait:
6840             FUN0(OP_WAIT);
6841
6842         case KEY_waitpid:
6843             LOP(OP_WAITPID,XTERM);
6844
6845         case KEY_wantarray:
6846             FUN0(OP_WANTARRAY);
6847
6848         case KEY_write:
6849 #ifdef EBCDIC
6850         {
6851             char ctl_l[2];
6852             ctl_l[0] = toCTRL('L');
6853             ctl_l[1] = '\0';
6854             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6855         }
6856 #else
6857             /* Make sure $^L is defined */
6858             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6859 #endif
6860             UNI(OP_ENTERWRITE);
6861
6862         case KEY_x:
6863             if (PL_expect == XOPERATOR)
6864                 Mop(OP_REPEAT);
6865             check_uni();
6866             goto just_a_word;
6867
6868         case KEY_xor:
6869             yylval.ival = OP_XOR;
6870             OPERATOR(OROP);
6871
6872         case KEY_y:
6873             s = scan_trans(s);
6874             TERM(sublex_start());
6875         }
6876     }}
6877 }
6878 #ifdef __SC__
6879 #pragma segment Main
6880 #endif
6881
6882 static int
6883 S_pending_ident(pTHX)
6884 {
6885     dVAR;
6886     register char *d;
6887     PADOFFSET tmp = 0;
6888     /* pit holds the identifier we read and pending_ident is reset */
6889     char pit = PL_pending_ident;
6890     PL_pending_ident = 0;
6891
6892     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6893     DEBUG_T({ PerlIO_printf(Perl_debug_log,
6894           "### Pending identifier '%s'\n", PL_tokenbuf); });
6895
6896     /* if we're in a my(), we can't allow dynamics here.
6897        $foo'bar has already been turned into $foo::bar, so
6898        just check for colons.
6899
6900        if it's a legal name, the OP is a PADANY.
6901     */
6902     if (PL_in_my) {
6903         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
6904             if (strchr(PL_tokenbuf,':'))
6905                 yyerror(Perl_form(aTHX_ "No package name allowed for "
6906                                   "variable %s in \"our\"",
6907                                   PL_tokenbuf));
6908             tmp = allocmy(PL_tokenbuf);
6909         }
6910         else {
6911             if (strchr(PL_tokenbuf,':'))
6912                 yyerror(Perl_form(aTHX_ PL_no_myglob,
6913                             PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6914
6915             yylval.opval = newOP(OP_PADANY, 0);
6916             yylval.opval->op_targ = allocmy(PL_tokenbuf);
6917             return PRIVATEREF;
6918         }
6919     }
6920
6921     /*
6922        build the ops for accesses to a my() variable.
6923
6924        Deny my($a) or my($b) in a sort block, *if* $a or $b is
6925        then used in a comparison.  This catches most, but not
6926        all cases.  For instance, it catches
6927            sort { my($a); $a <=> $b }
6928        but not
6929            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6930        (although why you'd do that is anyone's guess).
6931     */
6932
6933     if (!strchr(PL_tokenbuf,':')) {
6934         if (!PL_in_my)
6935             tmp = pad_findmy(PL_tokenbuf);
6936         if (tmp != NOT_IN_PAD) {
6937             /* might be an "our" variable" */
6938             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6939                 /* build ops for a bareword */
6940                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
6941                 HEK * const stashname = HvNAME_HEK(stash);
6942                 SV *  const sym = newSVhek(stashname);
6943                 sv_catpvs(sym, "::");
6944                 sv_catpv(sym, PL_tokenbuf+1);
6945                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6946                 yylval.opval->op_private = OPpCONST_ENTERED;
6947                 gv_fetchsv(sym,
6948                     (PL_in_eval
6949                         ? (GV_ADDMULTI | GV_ADDINEVAL)
6950                         : GV_ADDMULTI
6951                     ),
6952                     ((PL_tokenbuf[0] == '$') ? SVt_PV
6953                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6954                      : SVt_PVHV));
6955                 return WORD;
6956             }
6957
6958             /* if it's a sort block and they're naming $a or $b */
6959             if (PL_last_lop_op == OP_SORT &&
6960                 PL_tokenbuf[0] == '$' &&
6961                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6962                 && !PL_tokenbuf[2])
6963             {
6964                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6965                      d < PL_bufend && *d != '\n';
6966                      d++)
6967                 {
6968                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6969                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6970                               PL_tokenbuf);
6971                     }
6972                 }
6973             }
6974
6975             yylval.opval = newOP(OP_PADANY, 0);
6976             yylval.opval->op_targ = tmp;
6977             return PRIVATEREF;
6978         }
6979     }
6980
6981     /*
6982        Whine if they've said @foo in a doublequoted string,
6983        and @foo isn't a variable we can find in the symbol
6984        table.
6985     */
6986     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6987         GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6988         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6989              && ckWARN(WARN_AMBIGUOUS))
6990         {
6991             /* Downgraded from fatal to warning 20000522 mjd */
6992             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6993                         "Possible unintended interpolation of %s in string",
6994                          PL_tokenbuf);
6995         }
6996     }
6997
6998     /* build ops for a bareword */
6999     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
7000     yylval.opval->op_private = OPpCONST_ENTERED;
7001     gv_fetchpv(
7002             PL_tokenbuf+1,
7003             /* If the identifier refers to a stash, don't autovivify it.
7004              * Change 24660 had the side effect of causing symbol table
7005              * hashes to always be defined, even if they were freshly
7006              * created and the only reference in the entire program was
7007              * the single statement with the defined %foo::bar:: test.
7008              * It appears that all code in the wild doing this actually
7009              * wants to know whether sub-packages have been loaded, so
7010              * by avoiding auto-vivifying symbol tables, we ensure that
7011              * defined %foo::bar:: continues to be false, and the existing
7012              * tests still give the expected answers, even though what
7013              * they're actually testing has now changed subtly.
7014              */
7015             (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7016              ? 0
7017              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7018             ((PL_tokenbuf[0] == '$') ? SVt_PV
7019              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7020              : SVt_PVHV));
7021     return WORD;
7022 }
7023
7024 /*
7025  *  The following code was generated by perl_keyword.pl.
7026  */
7027
7028 I32
7029 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7030 {
7031     dVAR;
7032   switch (len)
7033   {
7034     case 1: /* 5 tokens of length 1 */
7035       switch (name[0])
7036       {
7037         case 'm':
7038           {                                       /* m          */
7039             return KEY_m;
7040           }
7041
7042         case 'q':
7043           {                                       /* q          */
7044             return KEY_q;
7045           }
7046
7047         case 's':
7048           {                                       /* s          */
7049             return KEY_s;
7050           }
7051
7052         case 'x':
7053           {                                       /* x          */
7054             return -KEY_x;
7055           }
7056
7057         case 'y':
7058           {                                       /* y          */
7059             return KEY_y;
7060           }
7061
7062         default:
7063           goto unknown;
7064       }
7065
7066     case 2: /* 18 tokens of length 2 */
7067       switch (name[0])
7068       {
7069         case 'd':
7070           if (name[1] == 'o')
7071           {                                       /* do         */
7072             return KEY_do;
7073           }
7074
7075           goto unknown;
7076
7077         case 'e':
7078           if (name[1] == 'q')
7079           {                                       /* eq         */
7080             return -KEY_eq;
7081           }
7082
7083           goto unknown;
7084
7085         case 'g':
7086           switch (name[1])
7087           {
7088             case 'e':
7089               {                                   /* ge         */
7090                 return -KEY_ge;
7091               }
7092
7093             case 't':
7094               {                                   /* gt         */
7095                 return -KEY_gt;
7096               }
7097
7098             default:
7099               goto unknown;
7100           }
7101
7102         case 'i':
7103           if (name[1] == 'f')
7104           {                                       /* if         */
7105             return KEY_if;
7106           }
7107
7108           goto unknown;
7109
7110         case 'l':
7111           switch (name[1])
7112           {
7113             case 'c':
7114               {                                   /* lc         */
7115                 return -KEY_lc;
7116               }
7117
7118             case 'e':
7119               {                                   /* le         */
7120                 return -KEY_le;
7121               }
7122
7123             case 't':
7124               {                                   /* lt         */
7125                 return -KEY_lt;
7126               }
7127
7128             default:
7129               goto unknown;
7130           }
7131
7132         case 'm':
7133           if (name[1] == 'y')
7134           {                                       /* my         */
7135             return KEY_my;
7136           }
7137
7138           goto unknown;
7139
7140         case 'n':
7141           switch (name[1])
7142           {
7143             case 'e':
7144               {                                   /* ne         */
7145                 return -KEY_ne;
7146               }
7147
7148             case 'o':
7149               {                                   /* no         */
7150                 return KEY_no;
7151               }
7152
7153             default:
7154               goto unknown;
7155           }
7156
7157         case 'o':
7158           if (name[1] == 'r')
7159           {                                       /* or         */
7160             return -KEY_or;
7161           }
7162
7163           goto unknown;
7164
7165         case 'q':
7166           switch (name[1])
7167           {
7168             case 'q':
7169               {                                   /* qq         */
7170                 return KEY_qq;
7171               }
7172
7173             case 'r':
7174               {                                   /* qr         */
7175                 return KEY_qr;
7176               }
7177
7178             case 'w':
7179               {                                   /* qw         */
7180                 return KEY_qw;
7181               }
7182
7183             case 'x':
7184               {                                   /* qx         */
7185                 return KEY_qx;
7186               }
7187
7188             default:
7189               goto unknown;
7190           }
7191
7192         case 't':
7193           if (name[1] == 'r')
7194           {                                       /* tr         */
7195             return KEY_tr;
7196           }
7197
7198           goto unknown;
7199
7200         case 'u':
7201           if (name[1] == 'c')
7202           {                                       /* uc         */
7203             return -KEY_uc;
7204           }
7205
7206           goto unknown;
7207
7208         default:
7209           goto unknown;
7210       }
7211
7212     case 3: /* 29 tokens of length 3 */
7213       switch (name[0])
7214       {
7215         case 'E':
7216           if (name[1] == 'N' &&
7217               name[2] == 'D')
7218           {                                       /* END        */
7219             return KEY_END;
7220           }
7221
7222           goto unknown;
7223
7224         case 'a':
7225           switch (name[1])
7226           {
7227             case 'b':
7228               if (name[2] == 's')
7229               {                                   /* abs        */
7230                 return -KEY_abs;
7231               }
7232
7233               goto unknown;
7234
7235             case 'n':
7236               if (name[2] == 'd')
7237               {                                   /* and        */
7238                 return -KEY_and;
7239               }
7240
7241               goto unknown;
7242
7243             default:
7244               goto unknown;
7245           }
7246
7247         case 'c':
7248           switch (name[1])
7249           {
7250             case 'h':
7251               if (name[2] == 'r')
7252               {                                   /* chr        */
7253                 return -KEY_chr;
7254               }
7255
7256               goto unknown;
7257
7258             case 'm':
7259               if (name[2] == 'p')
7260               {                                   /* cmp        */
7261                 return -KEY_cmp;
7262               }
7263
7264               goto unknown;
7265
7266             case 'o':
7267               if (name[2] == 's')
7268               {                                   /* cos        */
7269                 return -KEY_cos;
7270               }
7271
7272               goto unknown;
7273
7274             default:
7275               goto unknown;
7276           }
7277
7278         case 'd':
7279           if (name[1] == 'i' &&
7280               name[2] == 'e')
7281           {                                       /* die        */
7282             return -KEY_die;
7283           }
7284
7285           goto unknown;
7286
7287         case 'e':
7288           switch (name[1])
7289           {
7290             case 'o':
7291               if (name[2] == 'f')
7292               {                                   /* eof        */
7293                 return -KEY_eof;
7294               }
7295
7296               goto unknown;
7297
7298             case 'r':
7299               if (name[2] == 'r')
7300               {                                   /* err        */
7301                 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7302               }
7303
7304               goto unknown;
7305
7306             case 'x':
7307               if (name[2] == 'p')
7308               {                                   /* exp        */
7309                 return -KEY_exp;
7310               }
7311
7312               goto unknown;
7313
7314             default:
7315               goto unknown;
7316           }
7317
7318         case 'f':
7319           if (name[1] == 'o' &&
7320               name[2] == 'r')
7321           {                                       /* for        */
7322             return KEY_for;
7323           }
7324
7325           goto unknown;
7326
7327         case 'h':
7328           if (name[1] == 'e' &&
7329               name[2] == 'x')
7330           {                                       /* hex        */
7331             return -KEY_hex;
7332           }
7333
7334           goto unknown;
7335
7336         case 'i':
7337           if (name[1] == 'n' &&
7338               name[2] == 't')
7339           {                                       /* int        */
7340             return -KEY_int;
7341           }
7342
7343           goto unknown;
7344
7345         case 'l':
7346           if (name[1] == 'o' &&
7347               name[2] == 'g')
7348           {                                       /* log        */
7349             return -KEY_log;
7350           }
7351
7352           goto unknown;
7353
7354         case 'm':
7355           if (name[1] == 'a' &&
7356               name[2] == 'p')
7357           {                                       /* map        */
7358             return KEY_map;
7359           }
7360
7361           goto unknown;
7362
7363         case 'n':
7364           if (name[1] == 'o' &&
7365               name[2] == 't')
7366           {                                       /* not        */
7367             return -KEY_not;
7368           }
7369
7370           goto unknown;
7371
7372         case 'o':
7373           switch (name[1])
7374           {
7375             case 'c':
7376               if (name[2] == 't')
7377               {                                   /* oct        */
7378                 return -KEY_oct;
7379               }
7380
7381               goto unknown;
7382
7383             case 'r':
7384               if (name[2] == 'd')
7385               {                                   /* ord        */
7386                 return -KEY_ord;
7387               }
7388
7389               goto unknown;
7390
7391             case 'u':
7392               if (name[2] == 'r')
7393               {                                   /* our        */
7394                 return KEY_our;
7395               }
7396
7397               goto unknown;
7398
7399             default:
7400               goto unknown;
7401           }
7402
7403         case 'p':
7404           if (name[1] == 'o')
7405           {
7406             switch (name[2])
7407             {
7408               case 'p':
7409                 {                                 /* pop        */
7410                   return -KEY_pop;
7411                 }
7412
7413               case 's':
7414                 {                                 /* pos        */
7415                   return KEY_pos;
7416                 }
7417
7418               default:
7419                 goto unknown;
7420             }
7421           }
7422
7423           goto unknown;
7424
7425         case 'r':
7426           if (name[1] == 'e' &&
7427               name[2] == 'f')
7428           {                                       /* ref        */
7429             return -KEY_ref;
7430           }
7431
7432           goto unknown;
7433
7434         case 's':
7435           switch (name[1])
7436           {
7437             case 'a':
7438               if (name[2] == 'y')
7439               {                                   /* say        */
7440                 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7441               }
7442
7443               goto unknown;
7444
7445             case 'i':
7446               if (name[2] == 'n')
7447               {                                   /* sin        */
7448                 return -KEY_sin;
7449               }
7450
7451               goto unknown;
7452
7453             case 'u':
7454               if (name[2] == 'b')
7455               {                                   /* sub        */
7456                 return KEY_sub;
7457               }
7458
7459               goto unknown;
7460
7461             default:
7462               goto unknown;
7463           }
7464
7465         case 't':
7466           if (name[1] == 'i' &&
7467               name[2] == 'e')
7468           {                                       /* tie        */
7469             return KEY_tie;
7470           }
7471
7472           goto unknown;
7473
7474         case 'u':
7475           if (name[1] == 's' &&
7476               name[2] == 'e')
7477           {                                       /* use        */
7478             return KEY_use;
7479           }
7480
7481           goto unknown;
7482
7483         case 'v':
7484           if (name[1] == 'e' &&
7485               name[2] == 'c')
7486           {                                       /* vec        */
7487             return -KEY_vec;
7488           }
7489
7490           goto unknown;
7491
7492         case 'x':
7493           if (name[1] == 'o' &&
7494               name[2] == 'r')
7495           {                                       /* xor        */
7496             return -KEY_xor;
7497           }
7498
7499           goto unknown;
7500
7501         default:
7502           goto unknown;
7503       }
7504
7505     case 4: /* 41 tokens of length 4 */
7506       switch (name[0])
7507       {
7508         case 'C':
7509           if (name[1] == 'O' &&
7510               name[2] == 'R' &&
7511               name[3] == 'E')
7512           {                                       /* CORE       */
7513             return -KEY_CORE;
7514           }
7515
7516           goto unknown;
7517
7518         case 'I':
7519           if (name[1] == 'N' &&
7520               name[2] == 'I' &&
7521               name[3] == 'T')
7522           {                                       /* INIT       */
7523             return KEY_INIT;
7524           }
7525
7526           goto unknown;
7527
7528         case 'b':
7529           if (name[1] == 'i' &&
7530               name[2] == 'n' &&
7531               name[3] == 'd')
7532           {                                       /* bind       */
7533             return -KEY_bind;
7534           }
7535
7536           goto unknown;
7537
7538         case 'c':
7539           if (name[1] == 'h' &&
7540               name[2] == 'o' &&
7541               name[3] == 'p')
7542           {                                       /* chop       */
7543             return -KEY_chop;
7544           }
7545
7546           goto unknown;
7547
7548         case 'd':
7549           if (name[1] == 'u' &&
7550               name[2] == 'm' &&
7551               name[3] == 'p')
7552           {                                       /* dump       */
7553             return -KEY_dump;
7554           }
7555
7556           goto unknown;
7557
7558         case 'e':
7559           switch (name[1])
7560           {
7561             case 'a':
7562               if (name[2] == 'c' &&
7563                   name[3] == 'h')
7564               {                                   /* each       */
7565                 return -KEY_each;
7566               }
7567
7568               goto unknown;
7569
7570             case 'l':
7571               if (name[2] == 's' &&
7572                   name[3] == 'e')
7573               {                                   /* else       */
7574                 return KEY_else;
7575               }
7576
7577               goto unknown;
7578
7579             case 'v':
7580               if (name[2] == 'a' &&
7581                   name[3] == 'l')
7582               {                                   /* eval       */
7583                 return KEY_eval;
7584               }
7585
7586               goto unknown;
7587
7588             case 'x':
7589               switch (name[2])
7590               {
7591                 case 'e':
7592                   if (name[3] == 'c')
7593                   {                               /* exec       */
7594                     return -KEY_exec;
7595                   }
7596
7597                   goto unknown;
7598
7599                 case 'i':
7600                   if (name[3] == 't')
7601                   {                               /* exit       */
7602                     return -KEY_exit;
7603                   }
7604
7605                   goto unknown;
7606
7607                 default:
7608                   goto unknown;
7609               }
7610
7611             default:
7612               goto unknown;
7613           }
7614
7615         case 'f':
7616           if (name[1] == 'o' &&
7617               name[2] == 'r' &&
7618               name[3] == 'k')
7619           {                                       /* fork       */
7620             return -KEY_fork;
7621           }
7622
7623           goto unknown;
7624
7625         case 'g':
7626           switch (name[1])
7627           {
7628             case 'e':
7629               if (name[2] == 't' &&
7630                   name[3] == 'c')
7631               {                                   /* getc       */
7632                 return -KEY_getc;
7633               }
7634
7635               goto unknown;
7636
7637             case 'l':
7638               if (name[2] == 'o' &&
7639                   name[3] == 'b')
7640               {                                   /* glob       */
7641                 return KEY_glob;
7642               }
7643
7644               goto unknown;
7645
7646             case 'o':
7647               if (name[2] == 't' &&
7648                   name[3] == 'o')
7649               {                                   /* goto       */
7650                 return KEY_goto;
7651               }
7652
7653               goto unknown;
7654
7655             case 'r':
7656               if (name[2] == 'e' &&
7657                   name[3] == 'p')
7658               {                                   /* grep       */
7659                 return KEY_grep;
7660               }
7661
7662               goto unknown;
7663
7664             default:
7665               goto unknown;
7666           }
7667
7668         case 'j':
7669           if (name[1] == 'o' &&
7670               name[2] == 'i' &&
7671               name[3] == 'n')
7672           {                                       /* join       */
7673             return -KEY_join;
7674           }
7675
7676           goto unknown;
7677
7678         case 'k':
7679           switch (name[1])
7680           {
7681             case 'e':
7682               if (name[2] == 'y' &&
7683                   name[3] == 's')
7684               {                                   /* keys       */
7685                 return -KEY_keys;
7686               }
7687
7688               goto unknown;
7689
7690             case 'i':
7691               if (name[2] == 'l' &&
7692                   name[3] == 'l')
7693               {                                   /* kill       */
7694                 return -KEY_kill;
7695               }
7696
7697               goto unknown;
7698
7699             default:
7700               goto unknown;
7701           }
7702
7703         case 'l':
7704           switch (name[1])
7705           {
7706             case 'a':
7707               if (name[2] == 's' &&
7708                   name[3] == 't')
7709               {                                   /* last       */
7710                 return KEY_last;
7711               }
7712
7713               goto unknown;
7714
7715             case 'i':
7716               if (name[2] == 'n' &&
7717                   name[3] == 'k')
7718               {                                   /* link       */
7719                 return -KEY_link;
7720               }
7721
7722               goto unknown;
7723
7724             case 'o':
7725               if (name[2] == 'c' &&
7726                   name[3] == 'k')
7727               {                                   /* lock       */
7728                 return -KEY_lock;
7729               }
7730
7731               goto unknown;
7732
7733             default:
7734               goto unknown;
7735           }
7736
7737         case 'n':
7738           if (name[1] == 'e' &&
7739               name[2] == 'x' &&
7740               name[3] == 't')
7741           {                                       /* next       */
7742             return KEY_next;
7743           }
7744
7745           goto unknown;
7746
7747         case 'o':
7748           if (name[1] == 'p' &&
7749               name[2] == 'e' &&
7750               name[3] == 'n')
7751           {                                       /* open       */
7752             return -KEY_open;
7753           }
7754
7755           goto unknown;
7756
7757         case 'p':
7758           switch (name[1])
7759           {
7760             case 'a':
7761               if (name[2] == 'c' &&
7762                   name[3] == 'k')
7763               {                                   /* pack       */
7764                 return -KEY_pack;
7765               }
7766
7767               goto unknown;
7768
7769             case 'i':
7770               if (name[2] == 'p' &&
7771                   name[3] == 'e')
7772               {                                   /* pipe       */
7773                 return -KEY_pipe;
7774               }
7775
7776               goto unknown;
7777
7778             case 'u':
7779               if (name[2] == 's' &&
7780                   name[3] == 'h')
7781               {                                   /* push       */
7782                 return -KEY_push;
7783               }
7784
7785               goto unknown;
7786
7787             default:
7788               goto unknown;
7789           }
7790
7791         case 'r':
7792           switch (name[1])
7793           {
7794             case 'a':
7795               if (name[2] == 'n' &&
7796                   name[3] == 'd')
7797               {                                   /* rand       */
7798                 return -KEY_rand;
7799               }
7800
7801               goto unknown;
7802
7803             case 'e':
7804               switch (name[2])
7805               {
7806                 case 'a':
7807                   if (name[3] == 'd')
7808                   {                               /* read       */
7809                     return -KEY_read;
7810                   }
7811
7812                   goto unknown;
7813
7814                 case 'c':
7815                   if (name[3] == 'v')
7816                   {                               /* recv       */
7817                     return -KEY_recv;
7818                   }
7819
7820                   goto unknown;
7821
7822                 case 'd':
7823                   if (name[3] == 'o')
7824                   {                               /* redo       */
7825                     return KEY_redo;
7826                   }
7827
7828                   goto unknown;
7829
7830                 default:
7831                   goto unknown;
7832               }
7833
7834             default:
7835               goto unknown;
7836           }
7837
7838         case 's':
7839           switch (name[1])
7840           {
7841             case 'e':
7842               switch (name[2])
7843               {
7844                 case 'e':
7845                   if (name[3] == 'k')
7846                   {                               /* seek       */
7847                     return -KEY_seek;
7848                   }
7849
7850                   goto unknown;
7851
7852                 case 'n':
7853                   if (name[3] == 'd')
7854                   {                               /* send       */
7855                     return -KEY_send;
7856                   }
7857
7858                   goto unknown;
7859
7860                 default:
7861                   goto unknown;
7862               }
7863
7864             case 'o':
7865               if (name[2] == 'r' &&
7866                   name[3] == 't')
7867               {                                   /* sort       */
7868                 return KEY_sort;
7869               }
7870
7871               goto unknown;
7872
7873             case 'q':
7874               if (name[2] == 'r' &&
7875                   name[3] == 't')
7876               {                                   /* sqrt       */
7877                 return -KEY_sqrt;
7878               }
7879
7880               goto unknown;
7881
7882             case 't':
7883               if (name[2] == 'a' &&
7884                   name[3] == 't')
7885               {                                   /* stat       */
7886                 return -KEY_stat;
7887               }
7888
7889               goto unknown;
7890
7891             default:
7892               goto unknown;
7893           }
7894
7895         case 't':
7896           switch (name[1])
7897           {
7898             case 'e':
7899               if (name[2] == 'l' &&
7900                   name[3] == 'l')
7901               {                                   /* tell       */
7902                 return -KEY_tell;
7903               }
7904
7905               goto unknown;
7906
7907             case 'i':
7908               switch (name[2])
7909               {
7910                 case 'e':
7911                   if (name[3] == 'd')
7912                   {                               /* tied       */
7913                     return KEY_tied;
7914                   }
7915
7916                   goto unknown;
7917
7918                 case 'm':
7919                   if (name[3] == 'e')
7920                   {                               /* time       */
7921                     return -KEY_time;
7922                   }
7923
7924                   goto unknown;
7925
7926                 default:
7927                   goto unknown;
7928               }
7929
7930             default:
7931               goto unknown;
7932           }
7933
7934         case 'w':
7935           switch (name[1])
7936           {
7937             case 'a':
7938               switch (name[2])
7939               {
7940                 case 'i':
7941                   if (name[3] == 't')
7942                   {                               /* wait       */
7943                     return -KEY_wait;
7944                   }
7945
7946                   goto unknown;
7947
7948                 case 'r':
7949                   if (name[3] == 'n')
7950                   {                               /* warn       */
7951                     return -KEY_warn;
7952                   }
7953
7954                   goto unknown;
7955
7956                 default:
7957                   goto unknown;
7958               }
7959
7960             case 'h':
7961               if (name[2] == 'e' &&
7962                   name[3] == 'n')
7963               {                                   /* when       */
7964                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7965               }
7966
7967               goto unknown;
7968
7969             default:
7970               goto unknown;
7971           }
7972
7973         default:
7974           goto unknown;
7975       }
7976
7977     case 5: /* 39 tokens of length 5 */
7978       switch (name[0])
7979       {
7980         case 'B':
7981           if (name[1] == 'E' &&
7982               name[2] == 'G' &&
7983               name[3] == 'I' &&
7984               name[4] == 'N')
7985           {                                       /* BEGIN      */
7986             return KEY_BEGIN;
7987           }
7988
7989           goto unknown;
7990
7991         case 'C':
7992           if (name[1] == 'H' &&
7993               name[2] == 'E' &&
7994               name[3] == 'C' &&
7995               name[4] == 'K')
7996           {                                       /* CHECK      */
7997             return KEY_CHECK;
7998           }
7999
8000           goto unknown;
8001
8002         case 'a':
8003           switch (name[1])
8004           {
8005             case 'l':
8006               if (name[2] == 'a' &&
8007                   name[3] == 'r' &&
8008                   name[4] == 'm')
8009               {                                   /* alarm      */
8010                 return -KEY_alarm;
8011               }
8012
8013               goto unknown;
8014
8015             case 't':
8016               if (name[2] == 'a' &&
8017                   name[3] == 'n' &&
8018                   name[4] == '2')
8019               {                                   /* atan2      */
8020                 return -KEY_atan2;
8021               }
8022
8023               goto unknown;
8024
8025             default:
8026               goto unknown;
8027           }
8028
8029         case 'b':
8030           switch (name[1])
8031           {
8032             case 'l':
8033               if (name[2] == 'e' &&
8034                   name[3] == 's' &&
8035                   name[4] == 's')
8036               {                                   /* bless      */
8037                 return -KEY_bless;
8038               }
8039
8040               goto unknown;
8041
8042             case 'r':
8043               if (name[2] == 'e' &&
8044                   name[3] == 'a' &&
8045                   name[4] == 'k')
8046               {                                   /* break      */
8047                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8048               }
8049
8050               goto unknown;
8051
8052             default:
8053               goto unknown;
8054           }
8055
8056         case 'c':
8057           switch (name[1])
8058           {
8059             case 'h':
8060               switch (name[2])
8061               {
8062                 case 'd':
8063                   if (name[3] == 'i' &&
8064                       name[4] == 'r')
8065                   {                               /* chdir      */
8066                     return -KEY_chdir;
8067                   }
8068
8069                   goto unknown;
8070
8071                 case 'm':
8072                   if (name[3] == 'o' &&
8073                       name[4] == 'd')
8074                   {                               /* chmod      */
8075                     return -KEY_chmod;
8076                   }
8077
8078                   goto unknown;
8079
8080                 case 'o':
8081                   switch (name[3])
8082                   {
8083                     case 'm':
8084                       if (name[4] == 'p')
8085                       {                           /* chomp      */
8086                         return -KEY_chomp;
8087                       }
8088
8089                       goto unknown;
8090
8091                     case 'w':
8092                       if (name[4] == 'n')
8093                       {                           /* chown      */
8094                         return -KEY_chown;
8095                       }
8096
8097                       goto unknown;
8098
8099                     default:
8100                       goto unknown;
8101                   }
8102
8103                 default:
8104                   goto unknown;
8105               }
8106
8107             case 'l':
8108               if (name[2] == 'o' &&
8109                   name[3] == 's' &&
8110                   name[4] == 'e')
8111               {                                   /* close      */
8112                 return -KEY_close;
8113               }
8114
8115               goto unknown;
8116
8117             case 'r':
8118               if (name[2] == 'y' &&
8119                   name[3] == 'p' &&
8120                   name[4] == 't')
8121               {                                   /* crypt      */
8122                 return -KEY_crypt;
8123               }
8124
8125               goto unknown;
8126
8127             default:
8128               goto unknown;
8129           }
8130
8131         case 'e':
8132           if (name[1] == 'l' &&
8133               name[2] == 's' &&
8134               name[3] == 'i' &&
8135               name[4] == 'f')
8136           {                                       /* elsif      */
8137             return KEY_elsif;
8138           }
8139
8140           goto unknown;
8141
8142         case 'f':
8143           switch (name[1])
8144           {
8145             case 'c':
8146               if (name[2] == 'n' &&
8147                   name[3] == 't' &&
8148                   name[4] == 'l')
8149               {                                   /* fcntl      */
8150                 return -KEY_fcntl;
8151               }
8152
8153               goto unknown;
8154
8155             case 'l':
8156               if (name[2] == 'o' &&
8157                   name[3] == 'c' &&
8158                   name[4] == 'k')
8159               {                                   /* flock      */
8160                 return -KEY_flock;
8161               }
8162
8163               goto unknown;
8164
8165             default:
8166               goto unknown;
8167           }
8168
8169         case 'g':
8170           if (name[1] == 'i' &&
8171               name[2] == 'v' &&
8172               name[3] == 'e' &&
8173               name[4] == 'n')
8174           {                                       /* given      */
8175             return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8176           }
8177
8178           goto unknown;
8179
8180         case 'i':
8181           switch (name[1])
8182           {
8183             case 'n':
8184               if (name[2] == 'd' &&
8185                   name[3] == 'e' &&
8186                   name[4] == 'x')
8187               {                                   /* index      */
8188                 return -KEY_index;
8189               }
8190
8191               goto unknown;
8192
8193             case 'o':
8194               if (name[2] == 'c' &&
8195                   name[3] == 't' &&
8196                   name[4] == 'l')
8197               {                                   /* ioctl      */
8198                 return -KEY_ioctl;
8199               }
8200
8201               goto unknown;
8202
8203             default:
8204               goto unknown;
8205           }
8206
8207         case 'l':
8208           switch (name[1])
8209           {
8210             case 'o':
8211               if (name[2] == 'c' &&
8212                   name[3] == 'a' &&
8213                   name[4] == 'l')
8214               {                                   /* local      */
8215                 return KEY_local;
8216               }
8217
8218               goto unknown;
8219
8220             case 's':
8221               if (name[2] == 't' &&
8222                   name[3] == 'a' &&
8223                   name[4] == 't')
8224               {                                   /* lstat      */
8225                 return -KEY_lstat;
8226               }
8227
8228               goto unknown;
8229
8230             default:
8231               goto unknown;
8232           }
8233
8234         case 'm':
8235           if (name[1] == 'k' &&
8236               name[2] == 'd' &&
8237               name[3] == 'i' &&
8238               name[4] == 'r')
8239           {                                       /* mkdir      */
8240             return -KEY_mkdir;
8241           }
8242
8243           goto unknown;
8244
8245         case 'p':
8246           if (name[1] == 'r' &&
8247               name[2] == 'i' &&
8248               name[3] == 'n' &&
8249               name[4] == 't')
8250           {                                       /* print      */
8251             return KEY_print;
8252           }
8253
8254           goto unknown;
8255
8256         case 'r':
8257           switch (name[1])
8258           {
8259             case 'e':
8260               if (name[2] == 's' &&
8261                   name[3] == 'e' &&
8262                   name[4] == 't')
8263               {                                   /* reset      */
8264                 return -KEY_reset;
8265               }
8266
8267               goto unknown;
8268
8269             case 'm':
8270               if (name[2] == 'd' &&
8271                   name[3] == 'i' &&
8272                   name[4] == 'r')
8273               {                                   /* rmdir      */
8274                 return -KEY_rmdir;
8275               }
8276
8277               goto unknown;
8278
8279             default:
8280               goto unknown;
8281           }
8282
8283         case 's':
8284           switch (name[1])
8285           {
8286             case 'e':
8287               if (name[2] == 'm' &&
8288                   name[3] == 'o' &&
8289                   name[4] == 'p')
8290               {                                   /* semop      */
8291                 return -KEY_semop;
8292               }
8293
8294               goto unknown;
8295
8296             case 'h':
8297               if (name[2] == 'i' &&
8298                   name[3] == 'f' &&
8299                   name[4] == 't')
8300               {                                   /* shift      */
8301                 return -KEY_shift;
8302               }
8303
8304               goto unknown;
8305
8306             case 'l':
8307               if (name[2] == 'e' &&
8308                   name[3] == 'e' &&
8309                   name[4] == 'p')
8310               {                                   /* sleep      */
8311                 return -KEY_sleep;
8312               }
8313
8314               goto unknown;
8315
8316             case 'p':
8317               if (name[2] == 'l' &&
8318                   name[3] == 'i' &&
8319                   name[4] == 't')
8320               {                                   /* split      */
8321                 return KEY_split;
8322               }
8323
8324               goto unknown;
8325
8326             case 'r':
8327               if (name[2] == 'a' &&
8328                   name[3] == 'n' &&
8329                   name[4] == 'd')
8330               {                                   /* srand      */
8331                 return -KEY_srand;
8332               }
8333
8334               goto unknown;
8335
8336             case 't':
8337               switch (name[2])
8338               {
8339                 case 'a':
8340                   if (name[3] == 't' &&
8341                       name[4] == 'e')
8342                   {                               /* state      */
8343                     return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8344                   }
8345
8346                   goto unknown;
8347
8348                 case 'u':
8349                   if (name[3] == 'd' &&
8350                       name[4] == 'y')
8351                   {                               /* study      */
8352                     return KEY_study;
8353                   }
8354
8355                   goto unknown;
8356
8357                 default:
8358                   goto unknown;
8359               }
8360
8361             default:
8362               goto unknown;
8363           }
8364
8365         case 't':
8366           if (name[1] == 'i' &&
8367               name[2] == 'm' &&
8368               name[3] == 'e' &&
8369               name[4] == 's')
8370           {                                       /* times      */
8371             return -KEY_times;
8372           }
8373
8374           goto unknown;
8375
8376         case 'u':
8377           switch (name[1])
8378           {
8379             case 'm':
8380               if (name[2] == 'a' &&
8381                   name[3] == 's' &&
8382                   name[4] == 'k')
8383               {                                   /* umask      */
8384                 return -KEY_umask;
8385               }
8386
8387               goto unknown;
8388
8389             case 'n':
8390               switch (name[2])
8391               {
8392                 case 'd':
8393                   if (name[3] == 'e' &&
8394                       name[4] == 'f')
8395                   {                               /* undef      */
8396                     return KEY_undef;
8397                   }
8398
8399                   goto unknown;
8400
8401                 case 't':
8402                   if (name[3] == 'i')
8403                   {
8404                     switch (name[4])
8405                     {
8406                       case 'e':
8407                         {                         /* untie      */
8408                           return KEY_untie;
8409                         }
8410
8411                       case 'l':
8412                         {                         /* until      */
8413                           return KEY_until;
8414                         }
8415
8416                       default:
8417                         goto unknown;
8418                     }
8419                   }
8420
8421                   goto unknown;
8422
8423                 default:
8424                   goto unknown;
8425               }
8426
8427             case 't':
8428               if (name[2] == 'i' &&
8429                   name[3] == 'm' &&
8430                   name[4] == 'e')
8431               {                                   /* utime      */
8432                 return -KEY_utime;
8433               }
8434
8435               goto unknown;
8436
8437             default:
8438               goto unknown;
8439           }
8440
8441         case 'w':
8442           switch (name[1])
8443           {
8444             case 'h':
8445               if (name[2] == 'i' &&
8446                   name[3] == 'l' &&
8447                   name[4] == 'e')
8448               {                                   /* while      */
8449                 return KEY_while;
8450               }
8451
8452               goto unknown;
8453
8454             case 'r':
8455               if (name[2] == 'i' &&
8456                   name[3] == 't' &&
8457                   name[4] == 'e')
8458               {                                   /* write      */
8459                 return -KEY_write;
8460               }
8461
8462               goto unknown;
8463
8464             default:
8465               goto unknown;
8466           }
8467
8468         default:
8469           goto unknown;
8470       }
8471
8472     case 6: /* 33 tokens of length 6 */
8473       switch (name[0])
8474       {
8475         case 'a':
8476           if (name[1] == 'c' &&
8477               name[2] == 'c' &&
8478               name[3] == 'e' &&
8479               name[4] == 'p' &&
8480               name[5] == 't')
8481           {                                       /* accept     */
8482             return -KEY_accept;
8483           }
8484
8485           goto unknown;
8486
8487         case 'c':
8488           switch (name[1])
8489           {
8490             case 'a':
8491               if (name[2] == 'l' &&
8492                   name[3] == 'l' &&
8493                   name[4] == 'e' &&
8494                   name[5] == 'r')
8495               {                                   /* caller     */
8496                 return -KEY_caller;
8497               }
8498
8499               goto unknown;
8500
8501             case 'h':
8502               if (name[2] == 'r' &&
8503                   name[3] == 'o' &&
8504                   name[4] == 'o' &&
8505                   name[5] == 't')
8506               {                                   /* chroot     */
8507                 return -KEY_chroot;
8508               }
8509
8510               goto unknown;
8511
8512             default:
8513               goto unknown;
8514           }
8515
8516         case 'd':
8517           if (name[1] == 'e' &&
8518               name[2] == 'l' &&
8519               name[3] == 'e' &&
8520               name[4] == 't' &&
8521               name[5] == 'e')
8522           {                                       /* delete     */
8523             return KEY_delete;
8524           }
8525
8526           goto unknown;
8527
8528         case 'e':
8529           switch (name[1])
8530           {
8531             case 'l':
8532               if (name[2] == 's' &&
8533                   name[3] == 'e' &&
8534                   name[4] == 'i' &&
8535                   name[5] == 'f')
8536               {                                   /* elseif     */
8537                 if(ckWARN_d(WARN_SYNTAX))
8538                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8539               }
8540
8541               goto unknown;
8542
8543             case 'x':
8544               if (name[2] == 'i' &&
8545                   name[3] == 's' &&
8546                   name[4] == 't' &&
8547                   name[5] == 's')
8548               {                                   /* exists     */
8549                 return KEY_exists;
8550               }
8551
8552               goto unknown;
8553
8554             default:
8555               goto unknown;
8556           }
8557
8558         case 'f':
8559           switch (name[1])
8560           {
8561             case 'i':
8562               if (name[2] == 'l' &&
8563                   name[3] == 'e' &&
8564                   name[4] == 'n' &&
8565                   name[5] == 'o')
8566               {                                   /* fileno     */
8567                 return -KEY_fileno;
8568               }
8569
8570               goto unknown;
8571
8572             case 'o':
8573               if (name[2] == 'r' &&
8574                   name[3] == 'm' &&
8575                   name[4] == 'a' &&
8576                   name[5] == 't')
8577               {                                   /* format     */
8578                 return KEY_format;
8579               }
8580
8581               goto unknown;
8582
8583             default:
8584               goto unknown;
8585           }
8586
8587         case 'g':
8588           if (name[1] == 'm' &&
8589               name[2] == 't' &&
8590               name[3] == 'i' &&
8591               name[4] == 'm' &&
8592               name[5] == 'e')
8593           {                                       /* gmtime     */
8594             return -KEY_gmtime;
8595           }
8596
8597           goto unknown;
8598
8599         case 'l':
8600           switch (name[1])
8601           {
8602             case 'e':
8603               if (name[2] == 'n' &&
8604                   name[3] == 'g' &&
8605                   name[4] == 't' &&
8606                   name[5] == 'h')
8607               {                                   /* length     */
8608                 return -KEY_length;
8609               }
8610
8611               goto unknown;
8612
8613             case 'i':
8614               if (name[2] == 's' &&
8615                   name[3] == 't' &&
8616                   name[4] == 'e' &&
8617                   name[5] == 'n')
8618               {                                   /* listen     */
8619                 return -KEY_listen;
8620               }
8621
8622               goto unknown;
8623
8624             default:
8625               goto unknown;
8626           }
8627
8628         case 'm':
8629           if (name[1] == 's' &&
8630               name[2] == 'g')
8631           {
8632             switch (name[3])
8633             {
8634               case 'c':
8635                 if (name[4] == 't' &&
8636                     name[5] == 'l')
8637                 {                                 /* msgctl     */
8638                   return -KEY_msgctl;
8639                 }
8640
8641                 goto unknown;
8642
8643               case 'g':
8644                 if (name[4] == 'e' &&
8645                     name[5] == 't')
8646                 {                                 /* msgget     */
8647                   return -KEY_msgget;
8648                 }
8649
8650                 goto unknown;
8651
8652               case 'r':
8653                 if (name[4] == 'c' &&
8654                     name[5] == 'v')
8655                 {                                 /* msgrcv     */
8656                   return -KEY_msgrcv;
8657                 }
8658
8659                 goto unknown;
8660
8661               case 's':
8662                 if (name[4] == 'n' &&
8663                     name[5] == 'd')
8664                 {                                 /* msgsnd     */
8665                   return -KEY_msgsnd;
8666                 }
8667
8668                 goto unknown;
8669
8670               default:
8671                 goto unknown;
8672             }
8673           }
8674
8675           goto unknown;
8676
8677         case 'p':
8678           if (name[1] == 'r' &&
8679               name[2] == 'i' &&
8680               name[3] == 'n' &&
8681               name[4] == 't' &&
8682               name[5] == 'f')
8683           {                                       /* printf     */
8684             return KEY_printf;
8685           }
8686
8687           goto unknown;
8688
8689         case 'r':
8690           switch (name[1])
8691           {
8692             case 'e':
8693               switch (name[2])
8694               {
8695                 case 'n':
8696                   if (name[3] == 'a' &&
8697                       name[4] == 'm' &&
8698                       name[5] == 'e')
8699                   {                               /* rename     */
8700                     return -KEY_rename;
8701                   }
8702
8703                   goto unknown;
8704
8705                 case 't':
8706                   if (name[3] == 'u' &&
8707                       name[4] == 'r' &&
8708                       name[5] == 'n')
8709                   {                               /* return     */
8710                     return KEY_return;
8711                   }
8712
8713                   goto unknown;
8714
8715                 default:
8716                   goto unknown;
8717               }
8718
8719             case 'i':
8720               if (name[2] == 'n' &&
8721                   name[3] == 'd' &&
8722                   name[4] == 'e' &&
8723                   name[5] == 'x')
8724               {                                   /* rindex     */
8725                 return -KEY_rindex;
8726               }
8727
8728               goto unknown;
8729
8730             default:
8731               goto unknown;
8732           }
8733
8734         case 's':
8735           switch (name[1])
8736           {
8737             case 'c':
8738               if (name[2] == 'a' &&
8739                   name[3] == 'l' &&
8740                   name[4] == 'a' &&
8741                   name[5] == 'r')
8742               {                                   /* scalar     */
8743                 return KEY_scalar;
8744               }
8745
8746               goto unknown;
8747
8748             case 'e':
8749               switch (name[2])
8750               {
8751                 case 'l':
8752                   if (name[3] == 'e' &&
8753                       name[4] == 'c' &&
8754                       name[5] == 't')
8755                   {                               /* select     */
8756                     return -KEY_select;
8757                   }
8758
8759                   goto unknown;
8760
8761                 case 'm':
8762                   switch (name[3])
8763                   {
8764                     case 'c':
8765                       if (name[4] == 't' &&
8766                           name[5] == 'l')
8767                       {                           /* semctl     */
8768                         return -KEY_semctl;
8769                       }
8770
8771                       goto unknown;
8772
8773                     case 'g':
8774                       if (name[4] == 'e' &&
8775                           name[5] == 't')
8776                       {                           /* semget     */
8777                         return -KEY_semget;
8778                       }
8779
8780                       goto unknown;
8781
8782                     default:
8783                       goto unknown;
8784                   }
8785
8786                 default:
8787                   goto unknown;
8788               }
8789
8790             case 'h':
8791               if (name[2] == 'm')
8792               {
8793                 switch (name[3])
8794                 {
8795                   case 'c':
8796                     if (name[4] == 't' &&
8797                         name[5] == 'l')
8798                     {                             /* shmctl     */
8799                       return -KEY_shmctl;
8800                     }
8801
8802                     goto unknown;
8803
8804                   case 'g':
8805                     if (name[4] == 'e' &&
8806                         name[5] == 't')
8807                     {                             /* shmget     */
8808                       return -KEY_shmget;
8809                     }
8810
8811                     goto unknown;
8812
8813                   default:
8814                     goto unknown;
8815                 }
8816               }
8817
8818               goto unknown;
8819
8820             case 'o':
8821               if (name[2] == 'c' &&
8822                   name[3] == 'k' &&
8823                   name[4] == 'e' &&
8824                   name[5] == 't')
8825               {                                   /* socket     */
8826                 return -KEY_socket;
8827               }
8828
8829               goto unknown;
8830
8831             case 'p':
8832               if (name[2] == 'l' &&
8833                   name[3] == 'i' &&
8834                   name[4] == 'c' &&
8835                   name[5] == 'e')
8836               {                                   /* splice     */
8837                 return -KEY_splice;
8838               }
8839
8840               goto unknown;
8841
8842             case 'u':
8843               if (name[2] == 'b' &&
8844                   name[3] == 's' &&
8845                   name[4] == 't' &&
8846                   name[5] == 'r')
8847               {                                   /* substr     */
8848                 return -KEY_substr;
8849               }
8850
8851               goto unknown;
8852
8853             case 'y':
8854               if (name[2] == 's' &&
8855                   name[3] == 't' &&
8856                   name[4] == 'e' &&
8857                   name[5] == 'm')
8858               {                                   /* system     */
8859                 return -KEY_system;
8860               }
8861
8862               goto unknown;
8863
8864             default:
8865               goto unknown;
8866           }
8867
8868         case 'u':
8869           if (name[1] == 'n')
8870           {
8871             switch (name[2])
8872             {
8873               case 'l':
8874                 switch (name[3])
8875                 {
8876                   case 'e':
8877                     if (name[4] == 's' &&
8878                         name[5] == 's')
8879                     {                             /* unless     */
8880                       return KEY_unless;
8881                     }
8882
8883                     goto unknown;
8884
8885                   case 'i':
8886                     if (name[4] == 'n' &&
8887                         name[5] == 'k')
8888                     {                             /* unlink     */
8889                       return -KEY_unlink;
8890                     }
8891
8892                     goto unknown;
8893
8894                   default:
8895                     goto unknown;
8896                 }
8897
8898               case 'p':
8899                 if (name[3] == 'a' &&
8900                     name[4] == 'c' &&
8901                     name[5] == 'k')
8902                 {                                 /* unpack     */
8903                   return -KEY_unpack;
8904                 }
8905
8906                 goto unknown;
8907
8908               default:
8909                 goto unknown;
8910             }
8911           }
8912
8913           goto unknown;
8914
8915         case 'v':
8916           if (name[1] == 'a' &&
8917               name[2] == 'l' &&
8918               name[3] == 'u' &&
8919               name[4] == 'e' &&
8920               name[5] == 's')
8921           {                                       /* values     */
8922             return -KEY_values;
8923           }
8924
8925           goto unknown;
8926
8927         default:
8928           goto unknown;
8929       }
8930
8931     case 7: /* 29 tokens of length 7 */
8932       switch (name[0])
8933       {
8934         case 'D':
8935           if (name[1] == 'E' &&
8936               name[2] == 'S' &&
8937               name[3] == 'T' &&
8938               name[4] == 'R' &&
8939               name[5] == 'O' &&
8940               name[6] == 'Y')
8941           {                                       /* DESTROY    */
8942             return KEY_DESTROY;
8943           }
8944
8945           goto unknown;
8946
8947         case '_':
8948           if (name[1] == '_' &&
8949               name[2] == 'E' &&
8950               name[3] == 'N' &&
8951               name[4] == 'D' &&
8952               name[5] == '_' &&
8953               name[6] == '_')
8954           {                                       /* __END__    */
8955             return KEY___END__;
8956           }
8957
8958           goto unknown;
8959
8960         case 'b':
8961           if (name[1] == 'i' &&
8962               name[2] == 'n' &&
8963               name[3] == 'm' &&
8964               name[4] == 'o' &&
8965               name[5] == 'd' &&
8966               name[6] == 'e')
8967           {                                       /* binmode    */
8968             return -KEY_binmode;
8969           }
8970
8971           goto unknown;
8972
8973         case 'c':
8974           if (name[1] == 'o' &&
8975               name[2] == 'n' &&
8976               name[3] == 'n' &&
8977               name[4] == 'e' &&
8978               name[5] == 'c' &&
8979               name[6] == 't')
8980           {                                       /* connect    */
8981             return -KEY_connect;
8982           }
8983
8984           goto unknown;
8985
8986         case 'd':
8987           switch (name[1])
8988           {
8989             case 'b':
8990               if (name[2] == 'm' &&
8991                   name[3] == 'o' &&
8992                   name[4] == 'p' &&
8993                   name[5] == 'e' &&
8994                   name[6] == 'n')
8995               {                                   /* dbmopen    */
8996                 return -KEY_dbmopen;
8997               }
8998
8999               goto unknown;
9000
9001             case 'e':
9002               if (name[2] == 'f')
9003               {
9004                 switch (name[3])
9005                 {
9006                   case 'a':
9007                     if (name[4] == 'u' &&
9008                         name[5] == 'l' &&
9009                         name[6] == 't')
9010                     {                             /* default    */
9011                       return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9012                     }
9013
9014                     goto unknown;
9015
9016                   case 'i':
9017                     if (name[4] == 'n' &&
9018                         name[5] == 'e' &&
9019                         name[6] == 'd')
9020                     {                             /* defined    */
9021                       return KEY_defined;
9022                     }
9023
9024                     goto unknown;
9025
9026                   default:
9027                     goto unknown;
9028                 }
9029               }
9030
9031               goto unknown;
9032
9033             default:
9034               goto unknown;
9035           }
9036
9037         case 'f':
9038           if (name[1] == 'o' &&
9039               name[2] == 'r' &&
9040               name[3] == 'e' &&
9041               name[4] == 'a' &&
9042               name[5] == 'c' &&
9043               name[6] == 'h')
9044           {                                       /* foreach    */
9045             return KEY_foreach;
9046           }
9047
9048           goto unknown;
9049
9050         case 'g':
9051           if (name[1] == 'e' &&
9052               name[2] == 't' &&
9053               name[3] == 'p')
9054           {
9055             switch (name[4])
9056             {
9057               case 'g':
9058                 if (name[5] == 'r' &&
9059                     name[6] == 'p')
9060                 {                                 /* getpgrp    */
9061                   return -KEY_getpgrp;
9062                 }
9063
9064                 goto unknown;
9065
9066               case 'p':
9067                 if (name[5] == 'i' &&
9068                     name[6] == 'd')
9069                 {                                 /* getppid    */
9070                   return -KEY_getppid;
9071                 }
9072
9073                 goto unknown;
9074
9075               default:
9076                 goto unknown;
9077             }
9078           }
9079
9080           goto unknown;
9081
9082         case 'l':
9083           if (name[1] == 'c' &&
9084               name[2] == 'f' &&
9085               name[3] == 'i' &&
9086               name[4] == 'r' &&
9087               name[5] == 's' &&
9088               name[6] == 't')
9089           {                                       /* lcfirst    */
9090             return -KEY_lcfirst;
9091           }
9092
9093           goto unknown;
9094
9095         case 'o':
9096           if (name[1] == 'p' &&
9097               name[2] == 'e' &&
9098               name[3] == 'n' &&
9099               name[4] == 'd' &&
9100               name[5] == 'i' &&
9101               name[6] == 'r')
9102           {                                       /* opendir    */
9103             return -KEY_opendir;
9104           }
9105
9106           goto unknown;
9107
9108         case 'p':
9109           if (name[1] == 'a' &&
9110               name[2] == 'c' &&
9111               name[3] == 'k' &&
9112               name[4] == 'a' &&
9113               name[5] == 'g' &&
9114               name[6] == 'e')
9115           {                                       /* package    */
9116             return KEY_package;
9117           }
9118
9119           goto unknown;
9120
9121         case 'r':
9122           if (name[1] == 'e')
9123           {
9124             switch (name[2])
9125             {
9126               case 'a':
9127                 if (name[3] == 'd' &&
9128                     name[4] == 'd' &&
9129                     name[5] == 'i' &&
9130                     name[6] == 'r')
9131                 {                                 /* readdir    */
9132                   return -KEY_readdir;
9133                 }
9134
9135                 goto unknown;
9136
9137               case 'q':
9138                 if (name[3] == 'u' &&
9139                     name[4] == 'i' &&
9140                     name[5] == 'r' &&
9141                     name[6] == 'e')
9142                 {                                 /* require    */
9143                   return KEY_require;
9144                 }
9145
9146                 goto unknown;
9147
9148               case 'v':
9149                 if (name[3] == 'e' &&
9150                     name[4] == 'r' &&
9151                     name[5] == 's' &&
9152                     name[6] == 'e')
9153                 {                                 /* reverse    */
9154                   return -KEY_reverse;
9155                 }
9156
9157                 goto unknown;
9158
9159               default:
9160                 goto unknown;
9161             }
9162           }
9163
9164           goto unknown;
9165
9166         case 's':
9167           switch (name[1])
9168           {
9169             case 'e':
9170               switch (name[2])
9171               {
9172                 case 'e':
9173                   if (name[3] == 'k' &&
9174                       name[4] == 'd' &&
9175                       name[5] == 'i' &&
9176                       name[6] == 'r')
9177                   {                               /* seekdir    */
9178                     return -KEY_seekdir;
9179                   }
9180
9181                   goto unknown;
9182
9183                 case 't':
9184                   if (name[3] == 'p' &&
9185                       name[4] == 'g' &&
9186                       name[5] == 'r' &&
9187                       name[6] == 'p')
9188                   {                               /* setpgrp    */
9189                     return -KEY_setpgrp;
9190                   }
9191
9192                   goto unknown;
9193
9194                 default:
9195                   goto unknown;
9196               }
9197
9198             case 'h':
9199               if (name[2] == 'm' &&
9200                   name[3] == 'r' &&
9201                   name[4] == 'e' &&
9202                   name[5] == 'a' &&
9203                   name[6] == 'd')
9204               {                                   /* shmread    */
9205                 return -KEY_shmread;
9206               }
9207
9208               goto unknown;
9209
9210             case 'p':
9211               if (name[2] == 'r' &&
9212                   name[3] == 'i' &&
9213                   name[4] == 'n' &&
9214                   name[5] == 't' &&
9215                   name[6] == 'f')
9216               {                                   /* sprintf    */
9217                 return -KEY_sprintf;
9218               }
9219
9220               goto unknown;
9221
9222             case 'y':
9223               switch (name[2])
9224               {
9225                 case 'm':
9226                   if (name[3] == 'l' &&
9227                       name[4] == 'i' &&
9228                       name[5] == 'n' &&
9229                       name[6] == 'k')
9230                   {                               /* symlink    */
9231                     return -KEY_symlink;
9232                   }
9233
9234                   goto unknown;
9235
9236                 case 's':
9237                   switch (name[3])
9238                   {
9239                     case 'c':
9240                       if (name[4] == 'a' &&
9241                           name[5] == 'l' &&
9242                           name[6] == 'l')
9243                       {                           /* syscall    */
9244                         return -KEY_syscall;
9245                       }
9246
9247                       goto unknown;
9248
9249                     case 'o':
9250                       if (name[4] == 'p' &&
9251                           name[5] == 'e' &&
9252                           name[6] == 'n')
9253                       {                           /* sysopen    */
9254                         return -KEY_sysopen;
9255                       }
9256
9257                       goto unknown;
9258
9259                     case 'r':
9260                       if (name[4] == 'e' &&
9261                           name[5] == 'a' &&
9262                           name[6] == 'd')
9263                       {                           /* sysread    */
9264                         return -KEY_sysread;
9265                       }
9266
9267                       goto unknown;
9268
9269                     case 's':
9270                       if (name[4] == 'e' &&
9271                           name[5] == 'e' &&
9272                           name[6] == 'k')
9273                       {                           /* sysseek    */
9274                         return -KEY_sysseek;
9275                       }
9276
9277                       goto unknown;
9278
9279                     default:
9280                       goto unknown;
9281                   }
9282
9283                 default:
9284                   goto unknown;
9285               }
9286
9287             default:
9288               goto unknown;
9289           }
9290
9291         case 't':
9292           if (name[1] == 'e' &&
9293               name[2] == 'l' &&
9294               name[3] == 'l' &&
9295               name[4] == 'd' &&
9296               name[5] == 'i' &&
9297               name[6] == 'r')
9298           {                                       /* telldir    */
9299             return -KEY_telldir;
9300           }
9301
9302           goto unknown;
9303
9304         case 'u':
9305           switch (name[1])
9306           {
9307             case 'c':
9308               if (name[2] == 'f' &&
9309                   name[3] == 'i' &&
9310                   name[4] == 'r' &&
9311                   name[5] == 's' &&
9312                   name[6] == 't')
9313               {                                   /* ucfirst    */
9314                 return -KEY_ucfirst;
9315               }
9316
9317               goto unknown;
9318
9319             case 'n':
9320               if (name[2] == 's' &&
9321                   name[3] == 'h' &&
9322                   name[4] == 'i' &&
9323                   name[5] == 'f' &&
9324                   name[6] == 't')
9325               {                                   /* unshift    */
9326                 return -KEY_unshift;
9327               }
9328
9329               goto unknown;
9330
9331             default:
9332               goto unknown;
9333           }
9334
9335         case 'w':
9336           if (name[1] == 'a' &&
9337               name[2] == 'i' &&
9338               name[3] == 't' &&
9339               name[4] == 'p' &&
9340               name[5] == 'i' &&
9341               name[6] == 'd')
9342           {                                       /* waitpid    */
9343             return -KEY_waitpid;
9344           }
9345
9346           goto unknown;
9347
9348         default:
9349           goto unknown;
9350       }
9351
9352     case 8: /* 26 tokens of length 8 */
9353       switch (name[0])
9354       {
9355         case 'A':
9356           if (name[1] == 'U' &&
9357               name[2] == 'T' &&
9358               name[3] == 'O' &&
9359               name[4] == 'L' &&
9360               name[5] == 'O' &&
9361               name[6] == 'A' &&
9362               name[7] == 'D')
9363           {                                       /* AUTOLOAD   */
9364             return KEY_AUTOLOAD;
9365           }
9366
9367           goto unknown;
9368
9369         case '_':
9370           if (name[1] == '_')
9371           {
9372             switch (name[2])
9373             {
9374               case 'D':
9375                 if (name[3] == 'A' &&
9376                     name[4] == 'T' &&
9377                     name[5] == 'A' &&
9378                     name[6] == '_' &&
9379                     name[7] == '_')
9380                 {                                 /* __DATA__   */
9381                   return KEY___DATA__;
9382                 }
9383
9384                 goto unknown;
9385
9386               case 'F':
9387                 if (name[3] == 'I' &&
9388                     name[4] == 'L' &&
9389                     name[5] == 'E' &&
9390                     name[6] == '_' &&
9391                     name[7] == '_')
9392                 {                                 /* __FILE__   */
9393                   return -KEY___FILE__;
9394                 }
9395
9396                 goto unknown;
9397
9398               case 'L':
9399                 if (name[3] == 'I' &&
9400                     name[4] == 'N' &&
9401                     name[5] == 'E' &&
9402                     name[6] == '_' &&
9403                     name[7] == '_')
9404                 {                                 /* __LINE__   */
9405                   return -KEY___LINE__;
9406                 }
9407
9408                 goto unknown;
9409
9410               default:
9411                 goto unknown;
9412             }
9413           }
9414
9415           goto unknown;
9416
9417         case 'c':
9418           switch (name[1])
9419           {
9420             case 'l':
9421               if (name[2] == 'o' &&
9422                   name[3] == 's' &&
9423                   name[4] == 'e' &&
9424                   name[5] == 'd' &&
9425                   name[6] == 'i' &&
9426                   name[7] == 'r')
9427               {                                   /* closedir   */
9428                 return -KEY_closedir;
9429               }
9430
9431               goto unknown;
9432
9433             case 'o':
9434               if (name[2] == 'n' &&
9435                   name[3] == 't' &&
9436                   name[4] == 'i' &&
9437                   name[5] == 'n' &&
9438                   name[6] == 'u' &&
9439                   name[7] == 'e')
9440               {                                   /* continue   */
9441                 return -KEY_continue;
9442               }
9443
9444               goto unknown;
9445
9446             default:
9447               goto unknown;
9448           }
9449
9450         case 'd':
9451           if (name[1] == 'b' &&
9452               name[2] == 'm' &&
9453               name[3] == 'c' &&
9454               name[4] == 'l' &&
9455               name[5] == 'o' &&
9456               name[6] == 's' &&
9457               name[7] == 'e')
9458           {                                       /* dbmclose   */
9459             return -KEY_dbmclose;
9460           }
9461
9462           goto unknown;
9463
9464         case 'e':
9465           if (name[1] == 'n' &&
9466               name[2] == 'd')
9467           {
9468             switch (name[3])
9469             {
9470               case 'g':
9471                 if (name[4] == 'r' &&
9472                     name[5] == 'e' &&
9473                     name[6] == 'n' &&
9474                     name[7] == 't')
9475                 {                                 /* endgrent   */
9476                   return -KEY_endgrent;
9477                 }
9478
9479                 goto unknown;
9480
9481               case 'p':
9482                 if (name[4] == 'w' &&
9483                     name[5] == 'e' &&
9484                     name[6] == 'n' &&
9485                     name[7] == 't')
9486                 {                                 /* endpwent   */
9487                   return -KEY_endpwent;
9488                 }
9489
9490                 goto unknown;
9491
9492               default:
9493                 goto unknown;
9494             }
9495           }
9496
9497           goto unknown;
9498
9499         case 'f':
9500           if (name[1] == 'o' &&
9501               name[2] == 'r' &&
9502               name[3] == 'm' &&
9503               name[4] == 'l' &&
9504               name[5] == 'i' &&
9505               name[6] == 'n' &&
9506               name[7] == 'e')
9507           {                                       /* formline   */
9508             return -KEY_formline;
9509           }
9510
9511           goto unknown;
9512
9513         case 'g':
9514           if (name[1] == 'e' &&
9515               name[2] == 't')
9516           {
9517             switch (name[3])
9518             {
9519               case 'g':
9520                 if (name[4] == 'r')
9521                 {
9522                   switch (name[5])
9523                   {
9524                     case 'e':
9525                       if (name[6] == 'n' &&
9526                           name[7] == 't')
9527                       {                           /* getgrent   */
9528                         return -KEY_getgrent;
9529                       }
9530
9531                       goto unknown;
9532
9533                     case 'g':
9534                       if (name[6] == 'i' &&
9535                           name[7] == 'd')
9536                       {                           /* getgrgid   */
9537                         return -KEY_getgrgid;
9538                       }
9539
9540                       goto unknown;
9541
9542                     case 'n':
9543                       if (name[6] == 'a' &&
9544                           name[7] == 'm')
9545                       {                           /* getgrnam   */
9546                         return -KEY_getgrnam;
9547                       }
9548
9549                       goto unknown;
9550
9551                     default:
9552                       goto unknown;
9553                   }
9554                 }
9555
9556                 goto unknown;
9557
9558               case 'l':
9559                 if (name[4] == 'o' &&
9560                     name[5] == 'g' &&
9561                     name[6] == 'i' &&
9562                     name[7] == 'n')
9563                 {                                 /* getlogin   */
9564                   return -KEY_getlogin;
9565                 }
9566
9567                 goto unknown;
9568
9569               case 'p':
9570                 if (name[4] == 'w')
9571                 {
9572                   switch (name[5])
9573                   {
9574                     case 'e':
9575                       if (name[6] == 'n' &&
9576                           name[7] == 't')
9577                       {                           /* getpwent   */
9578                         return -KEY_getpwent;
9579                       }
9580
9581                       goto unknown;
9582
9583                     case 'n':
9584                       if (name[6] == 'a' &&
9585                           name[7] == 'm')
9586                       {                           /* getpwnam   */
9587                         return -KEY_getpwnam;
9588                       }
9589
9590                       goto unknown;
9591
9592                     case 'u':
9593                       if (name[6] == 'i' &&
9594                           name[7] == 'd')
9595                       {                           /* getpwuid   */
9596                         return -KEY_getpwuid;
9597                       }
9598
9599                       goto unknown;
9600
9601                     default:
9602                       goto unknown;
9603                   }
9604                 }
9605
9606                 goto unknown;
9607
9608               default:
9609                 goto unknown;
9610             }
9611           }
9612
9613           goto unknown;
9614
9615         case 'r':
9616           if (name[1] == 'e' &&
9617               name[2] == 'a' &&
9618               name[3] == 'd')
9619           {
9620             switch (name[4])
9621             {
9622               case 'l':
9623                 if (name[5] == 'i' &&
9624                     name[6] == 'n')
9625                 {
9626                   switch (name[7])
9627                   {
9628                     case 'e':
9629                       {                           /* readline   */
9630                         return -KEY_readline;
9631                       }
9632
9633                     case 'k':
9634                       {                           /* readlink   */
9635                         return -KEY_readlink;
9636                       }
9637
9638                     default:
9639                       goto unknown;
9640                   }
9641                 }
9642
9643                 goto unknown;
9644
9645               case 'p':
9646                 if (name[5] == 'i' &&
9647                     name[6] == 'p' &&
9648                     name[7] == 'e')
9649                 {                                 /* readpipe   */
9650                   return -KEY_readpipe;
9651                 }
9652
9653                 goto unknown;
9654
9655               default:
9656                 goto unknown;
9657             }
9658           }
9659
9660           goto unknown;
9661
9662         case 's':
9663           switch (name[1])
9664           {
9665             case 'e':
9666               if (name[2] == 't')
9667               {
9668                 switch (name[3])
9669                 {
9670                   case 'g':
9671                     if (name[4] == 'r' &&
9672                         name[5] == 'e' &&
9673                         name[6] == 'n' &&
9674                         name[7] == 't')
9675                     {                             /* setgrent   */
9676                       return -KEY_setgrent;
9677                     }
9678
9679                     goto unknown;
9680
9681                   case 'p':
9682                     if (name[4] == 'w' &&
9683                         name[5] == 'e' &&
9684                         name[6] == 'n' &&
9685                         name[7] == 't')
9686                     {                             /* setpwent   */
9687                       return -KEY_setpwent;
9688                     }
9689
9690                     goto unknown;
9691
9692                   default:
9693                     goto unknown;
9694                 }
9695               }
9696
9697               goto unknown;
9698
9699             case 'h':
9700               switch (name[2])
9701               {
9702                 case 'm':
9703                   if (name[3] == 'w' &&
9704                       name[4] == 'r' &&
9705                       name[5] == 'i' &&
9706                       name[6] == 't' &&
9707                       name[7] == 'e')
9708                   {                               /* shmwrite   */
9709                     return -KEY_shmwrite;
9710                   }
9711
9712                   goto unknown;
9713
9714                 case 'u':
9715                   if (name[3] == 't' &&
9716                       name[4] == 'd' &&
9717                       name[5] == 'o' &&
9718                       name[6] == 'w' &&
9719                       name[7] == 'n')
9720                   {                               /* shutdown   */
9721                     return -KEY_shutdown;
9722                   }
9723
9724                   goto unknown;
9725
9726                 default:
9727                   goto unknown;
9728               }
9729
9730             case 'y':
9731               if (name[2] == 's' &&
9732                   name[3] == 'w' &&
9733                   name[4] == 'r' &&
9734                   name[5] == 'i' &&
9735                   name[6] == 't' &&
9736                   name[7] == 'e')
9737               {                                   /* syswrite   */
9738                 return -KEY_syswrite;
9739               }
9740
9741               goto unknown;
9742
9743             default:
9744               goto unknown;
9745           }
9746
9747         case 't':
9748           if (name[1] == 'r' &&
9749               name[2] == 'u' &&
9750               name[3] == 'n' &&
9751               name[4] == 'c' &&
9752               name[5] == 'a' &&
9753               name[6] == 't' &&
9754               name[7] == 'e')
9755           {                                       /* truncate   */
9756             return -KEY_truncate;
9757           }
9758
9759           goto unknown;
9760
9761         default:
9762           goto unknown;
9763       }
9764
9765     case 9: /* 9 tokens of length 9 */
9766       switch (name[0])
9767       {
9768         case 'U':
9769           if (name[1] == 'N' &&
9770               name[2] == 'I' &&
9771               name[3] == 'T' &&
9772               name[4] == 'C' &&
9773               name[5] == 'H' &&
9774               name[6] == 'E' &&
9775               name[7] == 'C' &&
9776               name[8] == 'K')
9777           {                                       /* UNITCHECK  */
9778             return KEY_UNITCHECK;
9779           }
9780
9781           goto unknown;
9782
9783         case 'e':
9784           if (name[1] == 'n' &&
9785               name[2] == 'd' &&
9786               name[3] == 'n' &&
9787               name[4] == 'e' &&
9788               name[5] == 't' &&
9789               name[6] == 'e' &&
9790               name[7] == 'n' &&
9791               name[8] == 't')
9792           {                                       /* endnetent  */
9793             return -KEY_endnetent;
9794           }
9795
9796           goto unknown;
9797
9798         case 'g':
9799           if (name[1] == 'e' &&
9800               name[2] == 't' &&
9801               name[3] == 'n' &&
9802               name[4] == 'e' &&
9803               name[5] == 't' &&
9804               name[6] == 'e' &&
9805               name[7] == 'n' &&
9806               name[8] == 't')
9807           {                                       /* getnetent  */
9808             return -KEY_getnetent;
9809           }
9810
9811           goto unknown;
9812
9813         case 'l':
9814           if (name[1] == 'o' &&
9815               name[2] == 'c' &&
9816               name[3] == 'a' &&
9817               name[4] == 'l' &&
9818               name[5] == 't' &&
9819               name[6] == 'i' &&
9820               name[7] == 'm' &&
9821               name[8] == 'e')
9822           {                                       /* localtime  */
9823             return -KEY_localtime;
9824           }
9825
9826           goto unknown;
9827
9828         case 'p':
9829           if (name[1] == 'r' &&
9830               name[2] == 'o' &&
9831               name[3] == 't' &&
9832               name[4] == 'o' &&
9833               name[5] == 't' &&
9834               name[6] == 'y' &&
9835               name[7] == 'p' &&
9836               name[8] == 'e')
9837           {                                       /* prototype  */
9838             return KEY_prototype;
9839           }
9840
9841           goto unknown;
9842
9843         case 'q':
9844           if (name[1] == 'u' &&
9845               name[2] == 'o' &&
9846               name[3] == 't' &&
9847               name[4] == 'e' &&
9848               name[5] == 'm' &&
9849               name[6] == 'e' &&
9850               name[7] == 't' &&
9851               name[8] == 'a')
9852           {                                       /* quotemeta  */
9853             return -KEY_quotemeta;
9854           }
9855
9856           goto unknown;
9857
9858         case 'r':
9859           if (name[1] == 'e' &&
9860               name[2] == 'w' &&
9861               name[3] == 'i' &&
9862               name[4] == 'n' &&
9863               name[5] == 'd' &&
9864               name[6] == 'd' &&
9865               name[7] == 'i' &&
9866               name[8] == 'r')
9867           {                                       /* rewinddir  */
9868             return -KEY_rewinddir;
9869           }
9870
9871           goto unknown;
9872
9873         case 's':
9874           if (name[1] == 'e' &&
9875               name[2] == 't' &&
9876               name[3] == 'n' &&
9877               name[4] == 'e' &&
9878               name[5] == 't' &&
9879               name[6] == 'e' &&
9880               name[7] == 'n' &&
9881               name[8] == 't')
9882           {                                       /* setnetent  */
9883             return -KEY_setnetent;
9884           }
9885
9886           goto unknown;
9887
9888         case 'w':
9889           if (name[1] == 'a' &&
9890               name[2] == 'n' &&
9891               name[3] == 't' &&
9892               name[4] == 'a' &&
9893               name[5] == 'r' &&
9894               name[6] == 'r' &&
9895               name[7] == 'a' &&
9896               name[8] == 'y')
9897           {                                       /* wantarray  */
9898             return -KEY_wantarray;
9899           }
9900
9901           goto unknown;
9902
9903         default:
9904           goto unknown;
9905       }
9906
9907     case 10: /* 9 tokens of length 10 */
9908       switch (name[0])
9909       {
9910         case 'e':
9911           if (name[1] == 'n' &&
9912               name[2] == 'd')
9913           {
9914             switch (name[3])
9915             {
9916               case 'h':
9917                 if (name[4] == 'o' &&
9918                     name[5] == 's' &&
9919                     name[6] == 't' &&
9920                     name[7] == 'e' &&
9921                     name[8] == 'n' &&
9922                     name[9] == 't')
9923                 {                                 /* endhostent */
9924                   return -KEY_endhostent;
9925                 }
9926
9927                 goto unknown;
9928
9929               case 's':
9930                 if (name[4] == 'e' &&
9931                     name[5] == 'r' &&
9932                     name[6] == 'v' &&
9933                     name[7] == 'e' &&
9934                     name[8] == 'n' &&
9935                     name[9] == 't')
9936                 {                                 /* endservent */
9937                   return -KEY_endservent;
9938                 }
9939
9940                 goto unknown;
9941
9942               default:
9943                 goto unknown;
9944             }
9945           }
9946
9947           goto unknown;
9948
9949         case 'g':
9950           if (name[1] == 'e' &&
9951               name[2] == 't')
9952           {
9953             switch (name[3])
9954             {
9955               case 'h':
9956                 if (name[4] == 'o' &&
9957                     name[5] == 's' &&
9958                     name[6] == 't' &&
9959                     name[7] == 'e' &&
9960                     name[8] == 'n' &&
9961                     name[9] == 't')
9962                 {                                 /* gethostent */
9963                   return -KEY_gethostent;
9964                 }
9965
9966                 goto unknown;
9967
9968               case 's':
9969                 switch (name[4])
9970                 {
9971                   case 'e':
9972                     if (name[5] == 'r' &&
9973                         name[6] == 'v' &&
9974                         name[7] == 'e' &&
9975                         name[8] == 'n' &&
9976                         name[9] == 't')
9977                     {                             /* getservent */
9978                       return -KEY_getservent;
9979                     }
9980
9981                     goto unknown;
9982
9983                   case 'o':
9984                     if (name[5] == 'c' &&
9985                         name[6] == 'k' &&
9986                         name[7] == 'o' &&
9987                         name[8] == 'p' &&
9988                         name[9] == 't')
9989                     {                             /* getsockopt */
9990                       return -KEY_getsockopt;
9991                     }
9992
9993                     goto unknown;
9994
9995                   default:
9996                     goto unknown;
9997                 }
9998
9999               default:
10000                 goto unknown;
10001             }
10002           }
10003
10004           goto unknown;
10005
10006         case 's':
10007           switch (name[1])
10008           {
10009             case 'e':
10010               if (name[2] == 't')
10011               {
10012                 switch (name[3])
10013                 {
10014                   case 'h':
10015                     if (name[4] == 'o' &&
10016                         name[5] == 's' &&
10017                         name[6] == 't' &&
10018                         name[7] == 'e' &&
10019                         name[8] == 'n' &&
10020                         name[9] == 't')
10021                     {                             /* sethostent */
10022                       return -KEY_sethostent;
10023                     }
10024
10025                     goto unknown;
10026
10027                   case 's':
10028                     switch (name[4])
10029                     {
10030                       case 'e':
10031                         if (name[5] == 'r' &&
10032                             name[6] == 'v' &&
10033                             name[7] == 'e' &&
10034                             name[8] == 'n' &&
10035                             name[9] == 't')
10036                         {                         /* setservent */
10037                           return -KEY_setservent;
10038                         }
10039
10040                         goto unknown;
10041
10042                       case 'o':
10043                         if (name[5] == 'c' &&
10044                             name[6] == 'k' &&
10045                             name[7] == 'o' &&
10046                             name[8] == 'p' &&
10047                             name[9] == 't')
10048                         {                         /* setsockopt */
10049                           return -KEY_setsockopt;
10050                         }
10051
10052                         goto unknown;
10053
10054                       default:
10055                         goto unknown;
10056                     }
10057
10058                   default:
10059                     goto unknown;
10060                 }
10061               }
10062
10063               goto unknown;
10064
10065             case 'o':
10066               if (name[2] == 'c' &&
10067                   name[3] == 'k' &&
10068                   name[4] == 'e' &&
10069                   name[5] == 't' &&
10070                   name[6] == 'p' &&
10071                   name[7] == 'a' &&
10072                   name[8] == 'i' &&
10073                   name[9] == 'r')
10074               {                                   /* socketpair */
10075                 return -KEY_socketpair;
10076               }
10077
10078               goto unknown;
10079
10080             default:
10081               goto unknown;
10082           }
10083
10084         default:
10085           goto unknown;
10086       }
10087
10088     case 11: /* 8 tokens of length 11 */
10089       switch (name[0])
10090       {
10091         case '_':
10092           if (name[1] == '_' &&
10093               name[2] == 'P' &&
10094               name[3] == 'A' &&
10095               name[4] == 'C' &&
10096               name[5] == 'K' &&
10097               name[6] == 'A' &&
10098               name[7] == 'G' &&
10099               name[8] == 'E' &&
10100               name[9] == '_' &&
10101               name[10] == '_')
10102           {                                       /* __PACKAGE__ */
10103             return -KEY___PACKAGE__;
10104           }
10105
10106           goto unknown;
10107
10108         case 'e':
10109           if (name[1] == 'n' &&
10110               name[2] == 'd' &&
10111               name[3] == 'p' &&
10112               name[4] == 'r' &&
10113               name[5] == 'o' &&
10114               name[6] == 't' &&
10115               name[7] == 'o' &&
10116               name[8] == 'e' &&
10117               name[9] == 'n' &&
10118               name[10] == 't')
10119           {                                       /* endprotoent */
10120             return -KEY_endprotoent;
10121           }
10122
10123           goto unknown;
10124
10125         case 'g':
10126           if (name[1] == 'e' &&
10127               name[2] == 't')
10128           {
10129             switch (name[3])
10130             {
10131               case 'p':
10132                 switch (name[4])
10133                 {
10134                   case 'e':
10135                     if (name[5] == 'e' &&
10136                         name[6] == 'r' &&
10137                         name[7] == 'n' &&
10138                         name[8] == 'a' &&
10139                         name[9] == 'm' &&
10140                         name[10] == 'e')
10141                     {                             /* getpeername */
10142                       return -KEY_getpeername;
10143                     }
10144
10145                     goto unknown;
10146
10147                   case 'r':
10148                     switch (name[5])
10149                     {
10150                       case 'i':
10151                         if (name[6] == 'o' &&
10152                             name[7] == 'r' &&
10153                             name[8] == 'i' &&
10154                             name[9] == 't' &&
10155                             name[10] == 'y')
10156                         {                         /* getpriority */
10157                           return -KEY_getpriority;
10158                         }
10159
10160                         goto unknown;
10161
10162                       case 'o':
10163                         if (name[6] == 't' &&
10164                             name[7] == 'o' &&
10165                             name[8] == 'e' &&
10166                             name[9] == 'n' &&
10167                             name[10] == 't')
10168                         {                         /* getprotoent */
10169                           return -KEY_getprotoent;
10170                         }
10171
10172                         goto unknown;
10173
10174                       default:
10175                         goto unknown;
10176                     }
10177
10178                   default:
10179                     goto unknown;
10180                 }
10181
10182               case 's':
10183                 if (name[4] == 'o' &&
10184                     name[5] == 'c' &&
10185                     name[6] == 'k' &&
10186                     name[7] == 'n' &&
10187                     name[8] == 'a' &&
10188                     name[9] == 'm' &&
10189                     name[10] == 'e')
10190                 {                                 /* getsockname */
10191                   return -KEY_getsockname;
10192                 }
10193
10194                 goto unknown;
10195
10196               default:
10197                 goto unknown;
10198             }
10199           }
10200
10201           goto unknown;
10202
10203         case 's':
10204           if (name[1] == 'e' &&
10205               name[2] == 't' &&
10206               name[3] == 'p' &&
10207               name[4] == 'r')
10208           {
10209             switch (name[5])
10210             {
10211               case 'i':
10212                 if (name[6] == 'o' &&
10213                     name[7] == 'r' &&
10214                     name[8] == 'i' &&
10215                     name[9] == 't' &&
10216                     name[10] == 'y')
10217                 {                                 /* setpriority */
10218                   return -KEY_setpriority;
10219                 }
10220
10221                 goto unknown;
10222
10223               case 'o':
10224                 if (name[6] == 't' &&
10225                     name[7] == 'o' &&
10226                     name[8] == 'e' &&
10227                     name[9] == 'n' &&
10228                     name[10] == 't')
10229                 {                                 /* setprotoent */
10230                   return -KEY_setprotoent;
10231                 }
10232
10233                 goto unknown;
10234
10235               default:
10236                 goto unknown;
10237             }
10238           }
10239
10240           goto unknown;
10241
10242         default:
10243           goto unknown;
10244       }
10245
10246     case 12: /* 2 tokens of length 12 */
10247       if (name[0] == 'g' &&
10248           name[1] == 'e' &&
10249           name[2] == 't' &&
10250           name[3] == 'n' &&
10251           name[4] == 'e' &&
10252           name[5] == 't' &&
10253           name[6] == 'b' &&
10254           name[7] == 'y')
10255       {
10256         switch (name[8])
10257         {
10258           case 'a':
10259             if (name[9] == 'd' &&
10260                 name[10] == 'd' &&
10261                 name[11] == 'r')
10262             {                                     /* getnetbyaddr */
10263               return -KEY_getnetbyaddr;
10264             }
10265
10266             goto unknown;
10267
10268           case 'n':
10269             if (name[9] == 'a' &&
10270                 name[10] == 'm' &&
10271                 name[11] == 'e')
10272             {                                     /* getnetbyname */
10273               return -KEY_getnetbyname;
10274             }
10275
10276             goto unknown;
10277
10278           default:
10279             goto unknown;
10280         }
10281       }
10282
10283       goto unknown;
10284
10285     case 13: /* 4 tokens of length 13 */
10286       if (name[0] == 'g' &&
10287           name[1] == 'e' &&
10288           name[2] == 't')
10289       {
10290         switch (name[3])
10291         {
10292           case 'h':
10293             if (name[4] == 'o' &&
10294                 name[5] == 's' &&
10295                 name[6] == 't' &&
10296                 name[7] == 'b' &&
10297                 name[8] == 'y')
10298             {
10299               switch (name[9])
10300               {
10301                 case 'a':
10302                   if (name[10] == 'd' &&
10303                       name[11] == 'd' &&
10304                       name[12] == 'r')
10305                   {                               /* gethostbyaddr */
10306                     return -KEY_gethostbyaddr;
10307                   }
10308
10309                   goto unknown;
10310
10311                 case 'n':
10312                   if (name[10] == 'a' &&
10313                       name[11] == 'm' &&
10314                       name[12] == 'e')
10315                   {                               /* gethostbyname */
10316                     return -KEY_gethostbyname;
10317                   }
10318
10319                   goto unknown;
10320
10321                 default:
10322                   goto unknown;
10323               }
10324             }
10325
10326             goto unknown;
10327
10328           case 's':
10329             if (name[4] == 'e' &&
10330                 name[5] == 'r' &&
10331                 name[6] == 'v' &&
10332                 name[7] == 'b' &&
10333                 name[8] == 'y')
10334             {
10335               switch (name[9])
10336               {
10337                 case 'n':
10338                   if (name[10] == 'a' &&
10339                       name[11] == 'm' &&
10340                       name[12] == 'e')
10341                   {                               /* getservbyname */
10342                     return -KEY_getservbyname;
10343                   }
10344
10345                   goto unknown;
10346
10347                 case 'p':
10348                   if (name[10] == 'o' &&
10349                       name[11] == 'r' &&
10350                       name[12] == 't')
10351                   {                               /* getservbyport */
10352                     return -KEY_getservbyport;
10353                   }
10354
10355                   goto unknown;
10356
10357                 default:
10358                   goto unknown;
10359               }
10360             }
10361
10362             goto unknown;
10363
10364           default:
10365             goto unknown;
10366         }
10367       }
10368
10369       goto unknown;
10370
10371     case 14: /* 1 tokens of length 14 */
10372       if (name[0] == 'g' &&
10373           name[1] == 'e' &&
10374           name[2] == 't' &&
10375           name[3] == 'p' &&
10376           name[4] == 'r' &&
10377           name[5] == 'o' &&
10378           name[6] == 't' &&
10379           name[7] == 'o' &&
10380           name[8] == 'b' &&
10381           name[9] == 'y' &&
10382           name[10] == 'n' &&
10383           name[11] == 'a' &&
10384           name[12] == 'm' &&
10385           name[13] == 'e')
10386       {                                           /* getprotobyname */
10387         return -KEY_getprotobyname;
10388       }
10389
10390       goto unknown;
10391
10392     case 16: /* 1 tokens of length 16 */
10393       if (name[0] == 'g' &&
10394           name[1] == 'e' &&
10395           name[2] == 't' &&
10396           name[3] == 'p' &&
10397           name[4] == 'r' &&
10398           name[5] == 'o' &&
10399           name[6] == 't' &&
10400           name[7] == 'o' &&
10401           name[8] == 'b' &&
10402           name[9] == 'y' &&
10403           name[10] == 'n' &&
10404           name[11] == 'u' &&
10405           name[12] == 'm' &&
10406           name[13] == 'b' &&
10407           name[14] == 'e' &&
10408           name[15] == 'r')
10409       {                                           /* getprotobynumber */
10410         return -KEY_getprotobynumber;
10411       }
10412
10413       goto unknown;
10414
10415     default:
10416       goto unknown;
10417   }
10418
10419 unknown:
10420   return 0;
10421 }
10422
10423 STATIC void
10424 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10425 {
10426     dVAR;
10427
10428     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10429         if (ckWARN(WARN_SYNTAX)) {
10430             int level = 1;
10431             const char *w;
10432             for (w = s+2; *w && level; w++) {
10433                 if (*w == '(')
10434                     ++level;
10435                 else if (*w == ')')
10436                     --level;
10437             }
10438             while (isSPACE(*w))
10439                 ++w;
10440             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
10441                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10442                             "%s (...) interpreted as function",name);
10443         }
10444     }
10445     while (s < PL_bufend && isSPACE(*s))
10446         s++;
10447     if (*s == '(')
10448         s++;
10449     while (s < PL_bufend && isSPACE(*s))
10450         s++;
10451     if (isIDFIRST_lazy_if(s,UTF)) {
10452         const char * const w = s++;
10453         while (isALNUM_lazy_if(s,UTF))
10454             s++;
10455         while (s < PL_bufend && isSPACE(*s))
10456             s++;
10457         if (*s == ',') {
10458             GV* gv;
10459             if (keyword(w, s - w, 0))
10460                 return;
10461
10462             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10463             if (gv && GvCVu(gv))
10464                 return;
10465             Perl_croak(aTHX_ "No comma allowed after %s", what);
10466         }
10467     }
10468 }
10469
10470 /* Either returns sv, or mortalizes sv and returns a new SV*.
10471    Best used as sv=new_constant(..., sv, ...).
10472    If s, pv are NULL, calls subroutine with one argument,
10473    and type is used with error messages only. */
10474
10475 STATIC SV *
10476 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10477                const char *type)
10478 {
10479     dVAR; dSP;
10480     HV * const table = GvHV(PL_hintgv);          /* ^H */
10481     SV *res;
10482     SV **cvp;
10483     SV *cv, *typesv;
10484     const char *why1 = "", *why2 = "", *why3 = "";
10485
10486     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10487         SV *msg;
10488
10489         why2 = (const char *)
10490             (strEQ(key,"charnames")
10491              ? "(possibly a missing \"use charnames ...\")"
10492              : "");
10493         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10494                             (type ? type: "undef"), why2);
10495
10496         /* This is convoluted and evil ("goto considered harmful")
10497          * but I do not understand the intricacies of all the different
10498          * failure modes of %^H in here.  The goal here is to make
10499          * the most probable error message user-friendly. --jhi */
10500
10501         goto msgdone;
10502
10503     report:
10504         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10505                             (type ? type: "undef"), why1, why2, why3);
10506     msgdone:
10507         yyerror(SvPVX_const(msg));
10508         SvREFCNT_dec(msg);
10509         return sv;
10510     }
10511     cvp = hv_fetch(table, key, strlen(key), FALSE);
10512     if (!cvp || !SvOK(*cvp)) {
10513         why1 = "$^H{";
10514         why2 = key;
10515         why3 = "} is not defined";
10516         goto report;
10517     }
10518     sv_2mortal(sv);                     /* Parent created it permanently */
10519     cv = *cvp;
10520     if (!pv && s)
10521         pv = sv_2mortal(newSVpvn(s, len));
10522     if (type && pv)
10523         typesv = sv_2mortal(newSVpv(type, 0));
10524     else
10525         typesv = &PL_sv_undef;
10526
10527     PUSHSTACKi(PERLSI_OVERLOAD);
10528     ENTER ;
10529     SAVETMPS;
10530
10531     PUSHMARK(SP) ;
10532     EXTEND(sp, 3);
10533     if (pv)
10534         PUSHs(pv);
10535     PUSHs(sv);
10536     if (pv)
10537         PUSHs(typesv);
10538     PUTBACK;
10539     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10540
10541     SPAGAIN ;
10542
10543     /* Check the eval first */
10544     if (!PL_in_eval && SvTRUE(ERRSV)) {
10545         sv_catpvs(ERRSV, "Propagated");
10546         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10547         (void)POPs;
10548         res = SvREFCNT_inc_simple(sv);
10549     }
10550     else {
10551         res = POPs;
10552         SvREFCNT_inc_simple_void(res);
10553     }
10554
10555     PUTBACK ;
10556     FREETMPS ;
10557     LEAVE ;
10558     POPSTACK;
10559
10560     if (!SvOK(res)) {
10561         why1 = "Call to &{$^H{";
10562         why2 = key;
10563         why3 = "}} did not return a defined value";
10564         sv = res;
10565         goto report;
10566     }
10567
10568     return res;
10569 }
10570
10571 /* Returns a NUL terminated string, with the length of the string written to
10572    *slp
10573    */
10574 STATIC char *
10575 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10576 {
10577     dVAR;
10578     register char *d = dest;
10579     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10580     for (;;) {
10581         if (d >= e)
10582             Perl_croak(aTHX_ ident_too_long);
10583         if (isALNUM(*s))        /* UTF handled below */
10584             *d++ = *s++;
10585         else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10586             *d++ = ':';
10587             *d++ = ':';
10588             s++;
10589         }
10590         else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10591             *d++ = *s++;
10592             *d++ = *s++;
10593         }
10594         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10595             char *t = s + UTF8SKIP(s);
10596             size_t len;
10597             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10598                 t += UTF8SKIP(t);
10599             len = t - s;
10600             if (d + len > e)
10601                 Perl_croak(aTHX_ ident_too_long);
10602             Copy(s, d, len, char);
10603             d += len;
10604             s = t;
10605         }
10606         else {
10607             *d = '\0';
10608             *slp = d - dest;
10609             return s;
10610         }
10611     }
10612 }
10613
10614 STATIC char *
10615 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10616 {
10617     dVAR;
10618     char *bracket = NULL;
10619     char funny = *s++;
10620     register char *d = dest;
10621     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10622
10623     if (isSPACE(*s))
10624         s = PEEKSPACE(s);
10625     if (isDIGIT(*s)) {
10626         while (isDIGIT(*s)) {
10627             if (d >= e)
10628                 Perl_croak(aTHX_ ident_too_long);
10629             *d++ = *s++;
10630         }
10631     }
10632     else {
10633         for (;;) {
10634             if (d >= e)
10635                 Perl_croak(aTHX_ ident_too_long);
10636             if (isALNUM(*s))    /* UTF handled below */
10637                 *d++ = *s++;
10638             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10639                 *d++ = ':';
10640                 *d++ = ':';
10641                 s++;
10642             }
10643             else if (*s == ':' && s[1] == ':') {
10644                 *d++ = *s++;
10645                 *d++ = *s++;
10646             }
10647             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10648                 char *t = s + UTF8SKIP(s);
10649                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10650                     t += UTF8SKIP(t);
10651                 if (d + (t - s) > e)
10652                     Perl_croak(aTHX_ ident_too_long);
10653                 Copy(s, d, t - s, char);
10654                 d += t - s;
10655                 s = t;
10656             }
10657             else
10658                 break;
10659         }
10660     }
10661     *d = '\0';
10662     d = dest;
10663     if (*d) {
10664         if (PL_lex_state != LEX_NORMAL)
10665             PL_lex_state = LEX_INTERPENDMAYBE;
10666         return s;
10667     }
10668     if (*s == '$' && s[1] &&
10669         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10670     {
10671         return s;
10672     }
10673     if (*s == '{') {
10674         bracket = s;
10675         s++;
10676     }
10677     else if (ck_uni)
10678         check_uni();
10679     if (s < send)
10680         *d = *s++;
10681     d[1] = '\0';
10682     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10683         *d = toCTRL(*s);
10684         s++;
10685     }
10686     if (bracket) {
10687         if (isSPACE(s[-1])) {
10688             while (s < send) {
10689                 const char ch = *s++;
10690                 if (!SPACE_OR_TAB(ch)) {
10691                     *d = ch;
10692                     break;
10693                 }
10694             }
10695         }
10696         if (isIDFIRST_lazy_if(d,UTF)) {
10697             d++;
10698             if (UTF) {
10699                 char *end = s;
10700                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10701                     end += UTF8SKIP(end);
10702                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10703                         end += UTF8SKIP(end);
10704                 }
10705                 Copy(s, d, end - s, char);
10706                 d += end - s;
10707                 s = end;
10708             }
10709             else {
10710                 while ((isALNUM(*s) || *s == ':') && d < e)
10711                     *d++ = *s++;
10712                 if (d >= e)
10713                     Perl_croak(aTHX_ ident_too_long);
10714             }
10715             *d = '\0';
10716             while (s < send && SPACE_OR_TAB(*s))
10717                 s++;
10718             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10719                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10720                     const char * const brack =
10721                         (const char *)
10722                         ((*s == '[') ? "[...]" : "{...}");
10723                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10724                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10725                         funny, dest, brack, funny, dest, brack);
10726                 }
10727                 bracket++;
10728                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10729                 return s;
10730             }
10731         }
10732         /* Handle extended ${^Foo} variables
10733          * 1999-02-27 mjd-perl-patch@plover.com */
10734         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10735                  && isALNUM(*s))
10736         {
10737             d++;
10738             while (isALNUM(*s) && d < e) {
10739                 *d++ = *s++;
10740             }
10741             if (d >= e)
10742                 Perl_croak(aTHX_ ident_too_long);
10743             *d = '\0';
10744         }
10745         if (*s == '}') {
10746             s++;
10747             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10748                 PL_lex_state = LEX_INTERPEND;
10749                 PL_expect = XREF;
10750             }
10751             if (PL_lex_state == LEX_NORMAL) {
10752                 if (ckWARN(WARN_AMBIGUOUS) &&
10753                     (keyword(dest, d - dest, 0)
10754                      || get_cvn_flags(dest, d - dest, 0)))
10755                 {
10756                     if (funny == '#')
10757                         funny = '@';
10758                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10759                         "Ambiguous use of %c{%s} resolved to %c%s",
10760                         funny, dest, funny, dest);
10761                 }
10762             }
10763         }
10764         else {
10765             s = bracket;                /* let the parser handle it */
10766             *dest = '\0';
10767         }
10768     }
10769     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10770         PL_lex_state = LEX_INTERPEND;
10771     return s;
10772 }
10773
10774 void
10775 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10776 {
10777     PERL_UNUSED_CONTEXT;
10778     if (ch<256) {
10779         char c = (char)ch;
10780         switch (c) {
10781             CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10782             case GLOBAL_PAT_MOD:    *pmfl |= PMf_GLOBAL; break;
10783             case CONTINUE_PAT_MOD:  *pmfl |= PMf_CONTINUE; break;
10784             case ONCE_PAT_MOD:      *pmfl |= PMf_KEEP; break;
10785             case KEEPCOPY_PAT_MOD:  *pmfl |= PMf_KEEPCOPY; break;
10786         }
10787     }
10788 }
10789
10790 STATIC char *
10791 S_scan_pat(pTHX_ char *start, I32 type)
10792 {
10793     dVAR;
10794     PMOP *pm;
10795     char *s = scan_str(start,!!PL_madskills,FALSE);
10796     const char * const valid_flags =
10797         (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10798 #ifdef PERL_MAD
10799     char *modstart;
10800 #endif
10801
10802
10803     if (!s) {
10804         const char * const delimiter = skipspace(start);
10805         Perl_croak(aTHX_
10806                    (const char *)
10807                    (*delimiter == '?'
10808                     ? "Search pattern not terminated or ternary operator parsed as search pattern"
10809                     : "Search pattern not terminated" ));
10810     }
10811
10812     pm = (PMOP*)newPMOP(type, 0);
10813     if (PL_multi_open == '?')
10814         pm->op_pmflags |= PMf_ONCE;
10815 #ifdef PERL_MAD
10816     modstart = s;
10817 #endif
10818     while (*s && strchr(valid_flags, *s))
10819         pmflag(&pm->op_pmflags,*s++);
10820 #ifdef PERL_MAD
10821     if (PL_madskills && modstart != s) {
10822         SV* tmptoken = newSVpvn(modstart, s - modstart);
10823         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10824     }
10825 #endif
10826     /* issue a warning if /c is specified,but /g is not */
10827     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10828             && ckWARN(WARN_REGEXP))
10829     {
10830         Perl_warner(aTHX_ packWARN(WARN_REGEXP),
10831             "Use of /c modifier is meaningless without /g" );
10832     }
10833
10834     pm->op_pmpermflags = pm->op_pmflags;
10835
10836     PL_lex_op = (OP*)pm;
10837     yylval.ival = OP_MATCH;
10838     return s;
10839 }
10840
10841 STATIC char *
10842 S_scan_subst(pTHX_ char *start)
10843 {
10844     dVAR;
10845     register char *s;
10846     register PMOP *pm;
10847     I32 first_start;
10848     I32 es = 0;
10849 #ifdef PERL_MAD
10850     char *modstart;
10851 #endif
10852
10853     yylval.ival = OP_NULL;
10854
10855     s = scan_str(start,!!PL_madskills,FALSE);
10856
10857     if (!s)
10858         Perl_croak(aTHX_ "Substitution pattern not terminated");
10859
10860     if (s[-1] == PL_multi_open)
10861         s--;
10862 #ifdef PERL_MAD
10863     if (PL_madskills) {
10864         CURMAD('q', PL_thisopen);
10865         CURMAD('_', PL_thiswhite);
10866         CURMAD('E', PL_thisstuff);
10867         CURMAD('Q', PL_thisclose);
10868         PL_realtokenstart = s - SvPVX(PL_linestr);
10869     }
10870 #endif
10871
10872     first_start = PL_multi_start;
10873     s = scan_str(s,!!PL_madskills,FALSE);
10874     if (!s) {
10875         if (PL_lex_stuff) {
10876             SvREFCNT_dec(PL_lex_stuff);
10877             PL_lex_stuff = NULL;
10878         }
10879         Perl_croak(aTHX_ "Substitution replacement not terminated");
10880     }
10881     PL_multi_start = first_start;       /* so whole substitution is taken together */
10882
10883     pm = (PMOP*)newPMOP(OP_SUBST, 0);
10884
10885 #ifdef PERL_MAD
10886     if (PL_madskills) {
10887         CURMAD('z', PL_thisopen);
10888         CURMAD('R', PL_thisstuff);
10889         CURMAD('Z', PL_thisclose);
10890     }
10891     modstart = s;
10892 #endif
10893
10894     while (*s) {
10895         if (*s == EXEC_PAT_MOD) {
10896             s++;
10897             es++;
10898         }
10899         else if (strchr(S_PAT_MODS, *s))
10900             pmflag(&pm->op_pmflags,*s++);
10901         else
10902             break;
10903     }
10904
10905 #ifdef PERL_MAD
10906     if (PL_madskills) {
10907         if (modstart != s)
10908             curmad('m', newSVpvn(modstart, s - modstart));
10909         append_madprops(PL_thismad, (OP*)pm, 0);
10910         PL_thismad = 0;
10911     }
10912 #endif
10913     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10914         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10915     }
10916
10917     if (es) {
10918         SV * const repl = newSVpvs("");
10919
10920         PL_sublex_info.super_bufptr = s;
10921         PL_sublex_info.super_bufend = PL_bufend;
10922         PL_multi_end = 0;
10923         pm->op_pmflags |= PMf_EVAL;
10924         while (es-- > 0)
10925             sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10926         sv_catpvs(repl, "{");
10927         sv_catsv(repl, PL_lex_repl);
10928         if (strchr(SvPVX(PL_lex_repl), '#'))
10929             sv_catpvs(repl, "\n");
10930         sv_catpvs(repl, "}");
10931         SvEVALED_on(repl);
10932         SvREFCNT_dec(PL_lex_repl);
10933         PL_lex_repl = repl;
10934     }
10935
10936     pm->op_pmpermflags = pm->op_pmflags;
10937     PL_lex_op = (OP*)pm;
10938     yylval.ival = OP_SUBST;
10939     return s;
10940 }
10941
10942 STATIC char *
10943 S_scan_trans(pTHX_ char *start)
10944 {
10945     dVAR;
10946     register char* s;
10947     OP *o;
10948     short *tbl;
10949     I32 squash;
10950     I32 del;
10951     I32 complement;
10952 #ifdef PERL_MAD
10953     char *modstart;
10954 #endif
10955
10956     yylval.ival = OP_NULL;
10957
10958     s = scan_str(start,!!PL_madskills,FALSE);
10959     if (!s)
10960         Perl_croak(aTHX_ "Transliteration pattern not terminated");
10961
10962     if (s[-1] == PL_multi_open)
10963         s--;
10964 #ifdef PERL_MAD
10965     if (PL_madskills) {
10966         CURMAD('q', PL_thisopen);
10967         CURMAD('_', PL_thiswhite);
10968         CURMAD('E', PL_thisstuff);
10969         CURMAD('Q', PL_thisclose);
10970         PL_realtokenstart = s - SvPVX(PL_linestr);
10971     }
10972 #endif
10973
10974     s = scan_str(s,!!PL_madskills,FALSE);
10975     if (!s) {
10976         if (PL_lex_stuff) {
10977             SvREFCNT_dec(PL_lex_stuff);
10978             PL_lex_stuff = NULL;
10979         }
10980         Perl_croak(aTHX_ "Transliteration replacement not terminated");
10981     }
10982     if (PL_madskills) {
10983         CURMAD('z', PL_thisopen);
10984         CURMAD('R', PL_thisstuff);
10985         CURMAD('Z', PL_thisclose);
10986     }
10987
10988     complement = del = squash = 0;
10989 #ifdef PERL_MAD
10990     modstart = s;
10991 #endif
10992     while (1) {
10993         switch (*s) {
10994         case 'c':
10995             complement = OPpTRANS_COMPLEMENT;
10996             break;
10997         case 'd':
10998             del = OPpTRANS_DELETE;
10999             break;
11000         case 's':
11001             squash = OPpTRANS_SQUASH;
11002             break;
11003         default:
11004             goto no_more;
11005         }
11006         s++;
11007     }
11008   no_more:
11009
11010     tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11011     o = newPVOP(OP_TRANS, 0, (char*)tbl);
11012     o->op_private &= ~OPpTRANS_ALL;
11013     o->op_private |= del|squash|complement|
11014       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11015       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
11016
11017     PL_lex_op = o;
11018     yylval.ival = OP_TRANS;
11019
11020 #ifdef PERL_MAD
11021     if (PL_madskills) {
11022         if (modstart != s)
11023             curmad('m', newSVpvn(modstart, s - modstart));
11024         append_madprops(PL_thismad, o, 0);
11025         PL_thismad = 0;
11026     }
11027 #endif
11028
11029     return s;
11030 }
11031
11032 STATIC char *
11033 S_scan_heredoc(pTHX_ register char *s)
11034 {
11035     dVAR;
11036     SV *herewas;
11037     I32 op_type = OP_SCALAR;
11038     I32 len;
11039     SV *tmpstr;
11040     char term;
11041     const char *found_newline;
11042     register char *d;
11043     register char *e;
11044     char *peek;
11045     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11046 #ifdef PERL_MAD
11047     I32 stuffstart = s - SvPVX(PL_linestr);
11048     char *tstart;
11049
11050     PL_realtokenstart = -1;
11051 #endif
11052
11053     s += 2;
11054     d = PL_tokenbuf;
11055     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11056     if (!outer)
11057         *d++ = '\n';
11058     peek = s;
11059     while (SPACE_OR_TAB(*peek))
11060         peek++;
11061     if (*peek == '`' || *peek == '\'' || *peek =='"') {
11062         s = peek;
11063         term = *s++;
11064         s = delimcpy(d, e, s, PL_bufend, term, &len);
11065         d += len;
11066         if (s < PL_bufend)
11067             s++;
11068     }
11069     else {
11070         if (*s == '\\')
11071             s++, term = '\'';
11072         else
11073             term = '"';
11074         if (!isALNUM_lazy_if(s,UTF))
11075             deprecate_old("bare << to mean <<\"\"");
11076         for (; isALNUM_lazy_if(s,UTF); s++) {
11077             if (d < e)
11078                 *d++ = *s;
11079         }
11080     }
11081     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11082         Perl_croak(aTHX_ "Delimiter for here document is too long");
11083     *d++ = '\n';
11084     *d = '\0';
11085     len = d - PL_tokenbuf;
11086
11087 #ifdef PERL_MAD
11088     if (PL_madskills) {
11089         tstart = PL_tokenbuf + !outer;
11090         PL_thisclose = newSVpvn(tstart, len - !outer);
11091         tstart = SvPVX(PL_linestr) + stuffstart;
11092         PL_thisopen = newSVpvn(tstart, s - tstart);
11093         stuffstart = s - SvPVX(PL_linestr);
11094     }
11095 #endif
11096 #ifndef PERL_STRICT_CR
11097     d = strchr(s, '\r');
11098     if (d) {
11099         char * const olds = s;
11100         s = d;
11101         while (s < PL_bufend) {
11102             if (*s == '\r') {
11103                 *d++ = '\n';
11104                 if (*++s == '\n')
11105                     s++;
11106             }
11107             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
11108                 *d++ = *s++;
11109                 s++;
11110             }
11111             else
11112                 *d++ = *s++;
11113         }
11114         *d = '\0';
11115         PL_bufend = d;
11116         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11117         s = olds;
11118     }
11119 #endif
11120 #ifdef PERL_MAD
11121     found_newline = 0;
11122 #endif
11123     if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11124         herewas = newSVpvn(s,PL_bufend-s);
11125     }
11126     else {
11127 #ifdef PERL_MAD
11128         herewas = newSVpvn(s-1,found_newline-s+1);
11129 #else
11130         s--;
11131         herewas = newSVpvn(s,found_newline-s);
11132 #endif
11133     }
11134 #ifdef PERL_MAD
11135     if (PL_madskills) {
11136         tstart = SvPVX(PL_linestr) + stuffstart;
11137         if (PL_thisstuff)
11138             sv_catpvn(PL_thisstuff, tstart, s - tstart);
11139         else
11140             PL_thisstuff = newSVpvn(tstart, s - tstart);
11141     }
11142 #endif
11143     s += SvCUR(herewas);
11144
11145 #ifdef PERL_MAD
11146     stuffstart = s - SvPVX(PL_linestr);
11147
11148     if (found_newline)
11149         s--;
11150 #endif
11151
11152     tmpstr = newSV(79);
11153     sv_upgrade(tmpstr, SVt_PVIV);
11154     if (term == '\'') {
11155         op_type = OP_CONST;
11156         SvIV_set(tmpstr, -1);
11157     }
11158     else if (term == '`') {
11159         op_type = OP_BACKTICK;
11160         SvIV_set(tmpstr, '\\');
11161     }
11162
11163     CLINE;
11164     PL_multi_start = CopLINE(PL_curcop);
11165     PL_multi_open = PL_multi_close = '<';
11166     term = *PL_tokenbuf;
11167     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11168         char * const bufptr = PL_sublex_info.super_bufptr;
11169         char * const bufend = PL_sublex_info.super_bufend;
11170         char * const olds = s - SvCUR(herewas);
11171         s = strchr(bufptr, '\n');
11172         if (!s)
11173             s = bufend;
11174         d = s;
11175         while (s < bufend &&
11176           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11177             if (*s++ == '\n')
11178                 CopLINE_inc(PL_curcop);
11179         }
11180         if (s >= bufend) {
11181             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11182             missingterm(PL_tokenbuf);
11183         }
11184         sv_setpvn(herewas,bufptr,d-bufptr+1);
11185         sv_setpvn(tmpstr,d+1,s-d);
11186         s += len - 1;
11187         sv_catpvn(herewas,s,bufend-s);
11188         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11189
11190         s = olds;
11191         goto retval;
11192     }
11193     else if (!outer) {
11194         d = s;
11195         while (s < PL_bufend &&
11196           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11197             if (*s++ == '\n')
11198                 CopLINE_inc(PL_curcop);
11199         }
11200         if (s >= PL_bufend) {
11201             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11202             missingterm(PL_tokenbuf);
11203         }
11204         sv_setpvn(tmpstr,d+1,s-d);
11205 #ifdef PERL_MAD
11206         if (PL_madskills) {
11207             if (PL_thisstuff)
11208                 sv_catpvn(PL_thisstuff, d + 1, s - d);
11209             else
11210                 PL_thisstuff = newSVpvn(d + 1, s - d);
11211             stuffstart = s - SvPVX(PL_linestr);
11212         }
11213 #endif
11214         s += len - 1;
11215         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11216
11217         sv_catpvn(herewas,s,PL_bufend-s);
11218         sv_setsv(PL_linestr,herewas);
11219         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11220         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11221         PL_last_lop = PL_last_uni = NULL;
11222     }
11223     else
11224         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
11225     while (s >= PL_bufend) {    /* multiple line string? */
11226 #ifdef PERL_MAD
11227         if (PL_madskills) {
11228             tstart = SvPVX(PL_linestr) + stuffstart;
11229             if (PL_thisstuff)
11230                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11231             else
11232                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11233         }
11234 #endif
11235         if (!outer ||
11236          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11237             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11238             missingterm(PL_tokenbuf);
11239         }
11240 #ifdef PERL_MAD
11241         stuffstart = s - SvPVX(PL_linestr);
11242 #endif
11243         CopLINE_inc(PL_curcop);
11244         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11245         PL_last_lop = PL_last_uni = NULL;
11246 #ifndef PERL_STRICT_CR
11247         if (PL_bufend - PL_linestart >= 2) {
11248             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11249                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11250             {
11251                 PL_bufend[-2] = '\n';
11252                 PL_bufend--;
11253                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11254             }
11255             else if (PL_bufend[-1] == '\r')
11256                 PL_bufend[-1] = '\n';
11257         }
11258         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11259             PL_bufend[-1] = '\n';
11260 #endif
11261         if (PERLDB_LINE && PL_curstash != PL_debstash)
11262             update_debugger_info(PL_linestr, NULL, 0);
11263         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11264             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11265             *(SvPVX(PL_linestr) + off ) = ' ';
11266             sv_catsv(PL_linestr,herewas);
11267             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11268             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11269         }
11270         else {
11271             s = PL_bufend;
11272             sv_catsv(tmpstr,PL_linestr);
11273         }
11274     }
11275     s++;
11276 retval:
11277     PL_multi_end = CopLINE(PL_curcop);
11278     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11279         SvPV_shrink_to_cur(tmpstr);
11280     }
11281     SvREFCNT_dec(herewas);
11282     if (!IN_BYTES) {
11283         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11284             SvUTF8_on(tmpstr);
11285         else if (PL_encoding)
11286             sv_recode_to_utf8(tmpstr, PL_encoding);
11287     }
11288     PL_lex_stuff = tmpstr;
11289     yylval.ival = op_type;
11290     return s;
11291 }
11292
11293 /* scan_inputsymbol
11294    takes: current position in input buffer
11295    returns: new position in input buffer
11296    side-effects: yylval and lex_op are set.
11297
11298    This code handles:
11299
11300    <>           read from ARGV
11301    <FH>         read from filehandle
11302    <pkg::FH>    read from package qualified filehandle
11303    <pkg'FH>     read from package qualified filehandle
11304    <$fh>        read from filehandle in $fh
11305    <*.h>        filename glob
11306
11307 */
11308
11309 STATIC char *
11310 S_scan_inputsymbol(pTHX_ char *start)
11311 {
11312     dVAR;
11313     register char *s = start;           /* current position in buffer */
11314     char *end;
11315     I32 len;
11316
11317     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11318     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11319
11320     end = strchr(s, '\n');
11321     if (!end)
11322         end = PL_bufend;
11323     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11324
11325     /* die if we didn't have space for the contents of the <>,
11326        or if it didn't end, or if we see a newline
11327     */
11328
11329     if (len >= (I32)sizeof PL_tokenbuf)
11330         Perl_croak(aTHX_ "Excessively long <> operator");
11331     if (s >= end)
11332         Perl_croak(aTHX_ "Unterminated <> operator");
11333
11334     s++;
11335
11336     /* check for <$fh>
11337        Remember, only scalar variables are interpreted as filehandles by
11338        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11339        treated as a glob() call.
11340        This code makes use of the fact that except for the $ at the front,
11341        a scalar variable and a filehandle look the same.
11342     */
11343     if (*d == '$' && d[1]) d++;
11344
11345     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11346     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11347         d++;
11348
11349     /* If we've tried to read what we allow filehandles to look like, and
11350        there's still text left, then it must be a glob() and not a getline.
11351        Use scan_str to pull out the stuff between the <> and treat it
11352        as nothing more than a string.
11353     */
11354
11355     if (d - PL_tokenbuf != len) {
11356         yylval.ival = OP_GLOB;
11357         set_csh();
11358         s = scan_str(start,!!PL_madskills,FALSE);
11359         if (!s)
11360            Perl_croak(aTHX_ "Glob not terminated");
11361         return s;
11362     }
11363     else {
11364         bool readline_overriden = FALSE;
11365         GV *gv_readline;
11366         GV **gvp;
11367         /* we're in a filehandle read situation */
11368         d = PL_tokenbuf;
11369
11370         /* turn <> into <ARGV> */
11371         if (!len)
11372             Copy("ARGV",d,5,char);
11373
11374         /* Check whether readline() is overriden */
11375         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11376         if ((gv_readline
11377                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11378                 ||
11379                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11380                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11381                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11382             readline_overriden = TRUE;
11383
11384         /* if <$fh>, create the ops to turn the variable into a
11385            filehandle
11386         */
11387         if (*d == '$') {
11388             /* try to find it in the pad for this block, otherwise find
11389                add symbol table ops
11390             */
11391             const PADOFFSET tmp = pad_findmy(d);
11392             if (tmp != NOT_IN_PAD) {
11393                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11394                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11395                     HEK * const stashname = HvNAME_HEK(stash);
11396                     SV * const sym = sv_2mortal(newSVhek(stashname));
11397                     sv_catpvs(sym, "::");
11398                     sv_catpv(sym, d+1);
11399                     d = SvPVX(sym);
11400                     goto intro_sym;
11401                 }
11402                 else {
11403                     OP * const o = newOP(OP_PADSV, 0);
11404                     o->op_targ = tmp;
11405                     PL_lex_op = readline_overriden
11406                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11407                                 append_elem(OP_LIST, o,
11408                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11409                         : (OP*)newUNOP(OP_READLINE, 0, o);
11410                 }
11411             }
11412             else {
11413                 GV *gv;
11414                 ++d;
11415 intro_sym:
11416                 gv = gv_fetchpv(d,
11417                                 (PL_in_eval
11418                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11419                                  : GV_ADDMULTI),
11420                                 SVt_PV);
11421                 PL_lex_op = readline_overriden
11422                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11423                             append_elem(OP_LIST,
11424                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11425                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11426                     : (OP*)newUNOP(OP_READLINE, 0,
11427                             newUNOP(OP_RV2SV, 0,
11428                                 newGVOP(OP_GV, 0, gv)));
11429             }
11430             if (!readline_overriden)
11431                 PL_lex_op->op_flags |= OPf_SPECIAL;
11432             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11433             yylval.ival = OP_NULL;
11434         }
11435
11436         /* If it's none of the above, it must be a literal filehandle
11437            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11438         else {
11439             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11440             PL_lex_op = readline_overriden
11441                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11442                         append_elem(OP_LIST,
11443                             newGVOP(OP_GV, 0, gv),
11444                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11445                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11446             yylval.ival = OP_NULL;
11447         }
11448     }
11449
11450     return s;
11451 }
11452
11453
11454 /* scan_str
11455    takes: start position in buffer
11456           keep_quoted preserve \ on the embedded delimiter(s)
11457           keep_delims preserve the delimiters around the string
11458    returns: position to continue reading from buffer
11459    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11460         updates the read buffer.
11461
11462    This subroutine pulls a string out of the input.  It is called for:
11463         q               single quotes           q(literal text)
11464         '               single quotes           'literal text'
11465         qq              double quotes           qq(interpolate $here please)
11466         "               double quotes           "interpolate $here please"
11467         qx              backticks               qx(/bin/ls -l)
11468         `               backticks               `/bin/ls -l`
11469         qw              quote words             @EXPORT_OK = qw( func() $spam )
11470         m//             regexp match            m/this/
11471         s///            regexp substitute       s/this/that/
11472         tr///           string transliterate    tr/this/that/
11473         y///            string transliterate    y/this/that/
11474         ($*@)           sub prototypes          sub foo ($)
11475         (stuff)         sub attr parameters     sub foo : attr(stuff)
11476         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11477
11478    In most of these cases (all but <>, patterns and transliterate)
11479    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11480    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11481    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11482    calls scan_str().
11483
11484    It skips whitespace before the string starts, and treats the first
11485    character as the delimiter.  If the delimiter is one of ([{< then
11486    the corresponding "close" character )]}> is used as the closing
11487    delimiter.  It allows quoting of delimiters, and if the string has
11488    balanced delimiters ([{<>}]) it allows nesting.
11489
11490    On success, the SV with the resulting string is put into lex_stuff or,
11491    if that is already non-NULL, into lex_repl. The second case occurs only
11492    when parsing the RHS of the special constructs s/// and tr/// (y///).
11493    For convenience, the terminating delimiter character is stuffed into
11494    SvIVX of the SV.
11495 */
11496
11497 STATIC char *
11498 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11499 {
11500     dVAR;
11501     SV *sv;                             /* scalar value: string */
11502     const char *tmps;                   /* temp string, used for delimiter matching */
11503     register char *s = start;           /* current position in the buffer */
11504     register char term;                 /* terminating character */
11505     register char *to;                  /* current position in the sv's data */
11506     I32 brackets = 1;                   /* bracket nesting level */
11507     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11508     I32 termcode;                       /* terminating char. code */
11509     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11510     STRLEN termlen;                     /* length of terminating string */
11511     int last_off = 0;                   /* last position for nesting bracket */
11512 #ifdef PERL_MAD
11513     int stuffstart;
11514     char *tstart;
11515 #endif
11516
11517     /* skip space before the delimiter */
11518     if (isSPACE(*s)) {
11519         s = PEEKSPACE(s);
11520     }
11521
11522 #ifdef PERL_MAD
11523     if (PL_realtokenstart >= 0) {
11524         stuffstart = PL_realtokenstart;
11525         PL_realtokenstart = -1;
11526     }
11527     else
11528         stuffstart = start - SvPVX(PL_linestr);
11529 #endif
11530     /* mark where we are, in case we need to report errors */
11531     CLINE;
11532
11533     /* after skipping whitespace, the next character is the terminator */
11534     term = *s;
11535     if (!UTF) {
11536         termcode = termstr[0] = term;
11537         termlen = 1;
11538     }
11539     else {
11540         termcode = utf8_to_uvchr((U8*)s, &termlen);
11541         Copy(s, termstr, termlen, U8);
11542         if (!UTF8_IS_INVARIANT(term))
11543             has_utf8 = TRUE;
11544     }
11545
11546     /* mark where we are */
11547     PL_multi_start = CopLINE(PL_curcop);
11548     PL_multi_open = term;
11549
11550     /* find corresponding closing delimiter */
11551     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11552         termcode = termstr[0] = term = tmps[5];
11553
11554     PL_multi_close = term;
11555
11556     /* create a new SV to hold the contents.  79 is the SV's initial length.
11557        What a random number. */
11558     sv = newSV(79);
11559     sv_upgrade(sv, SVt_PVIV);
11560     SvIV_set(sv, termcode);
11561     (void)SvPOK_only(sv);               /* validate pointer */
11562
11563     /* move past delimiter and try to read a complete string */
11564     if (keep_delims)
11565         sv_catpvn(sv, s, termlen);
11566     s += termlen;
11567 #ifdef PERL_MAD
11568     tstart = SvPVX(PL_linestr) + stuffstart;
11569     if (!PL_thisopen && !keep_delims) {
11570         PL_thisopen = newSVpvn(tstart, s - tstart);
11571         stuffstart = s - SvPVX(PL_linestr);
11572     }
11573 #endif
11574     for (;;) {
11575         if (PL_encoding && !UTF) {
11576             bool cont = TRUE;
11577
11578             while (cont) {
11579                 int offset = s - SvPVX_const(PL_linestr);
11580                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11581                                            &offset, (char*)termstr, termlen);
11582                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11583                 char * const svlast = SvEND(sv) - 1;
11584
11585                 for (; s < ns; s++) {
11586                     if (*s == '\n' && !PL_rsfp)
11587                         CopLINE_inc(PL_curcop);
11588                 }
11589                 if (!found)
11590                     goto read_more_line;
11591                 else {
11592                     /* handle quoted delimiters */
11593                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11594                         const char *t;
11595                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11596                             t--;
11597                         if ((svlast-1 - t) % 2) {
11598                             if (!keep_quoted) {
11599                                 *(svlast-1) = term;
11600                                 *svlast = '\0';
11601                                 SvCUR_set(sv, SvCUR(sv) - 1);
11602                             }
11603                             continue;
11604                         }
11605                     }
11606                     if (PL_multi_open == PL_multi_close) {
11607                         cont = FALSE;
11608                     }
11609                     else {
11610                         const char *t;
11611                         char *w;
11612                         for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11613                             /* At here, all closes are "was quoted" one,
11614                                so we don't check PL_multi_close. */
11615                             if (*t == '\\') {
11616                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11617                                     t++;
11618                                 else
11619                                     *w++ = *t++;
11620                             }
11621                             else if (*t == PL_multi_open)
11622                                 brackets++;
11623
11624                             *w = *t;
11625                         }
11626                         if (w < t) {
11627                             *w++ = term;
11628                             *w = '\0';
11629                             SvCUR_set(sv, w - SvPVX_const(sv));
11630                         }
11631                         last_off = w - SvPVX(sv);
11632                         if (--brackets <= 0)
11633                             cont = FALSE;
11634                     }
11635                 }
11636             }
11637             if (!keep_delims) {
11638                 SvCUR_set(sv, SvCUR(sv) - 1);
11639                 *SvEND(sv) = '\0';
11640             }
11641             break;
11642         }
11643
11644         /* extend sv if need be */
11645         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11646         /* set 'to' to the next character in the sv's string */
11647         to = SvPVX(sv)+SvCUR(sv);
11648
11649         /* if open delimiter is the close delimiter read unbridle */
11650         if (PL_multi_open == PL_multi_close) {
11651             for (; s < PL_bufend; s++,to++) {
11652                 /* embedded newlines increment the current line number */
11653                 if (*s == '\n' && !PL_rsfp)
11654                     CopLINE_inc(PL_curcop);
11655                 /* handle quoted delimiters */
11656                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11657                     if (!keep_quoted && s[1] == term)
11658                         s++;
11659                 /* any other quotes are simply copied straight through */
11660                     else
11661                         *to++ = *s++;
11662                 }
11663                 /* terminate when run out of buffer (the for() condition), or
11664                    have found the terminator */
11665                 else if (*s == term) {
11666                     if (termlen == 1)
11667                         break;
11668                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11669                         break;
11670                 }
11671                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11672                     has_utf8 = TRUE;
11673                 *to = *s;
11674             }
11675         }
11676
11677         /* if the terminator isn't the same as the start character (e.g.,
11678            matched brackets), we have to allow more in the quoting, and
11679            be prepared for nested brackets.
11680         */
11681         else {
11682             /* read until we run out of string, or we find the terminator */
11683             for (; s < PL_bufend; s++,to++) {
11684                 /* embedded newlines increment the line count */
11685                 if (*s == '\n' && !PL_rsfp)
11686                     CopLINE_inc(PL_curcop);
11687                 /* backslashes can escape the open or closing characters */
11688                 if (*s == '\\' && s+1 < PL_bufend) {
11689                     if (!keep_quoted &&
11690                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11691                         s++;
11692                     else
11693                         *to++ = *s++;
11694                 }
11695                 /* allow nested opens and closes */
11696                 else if (*s == PL_multi_close && --brackets <= 0)
11697                     break;
11698                 else if (*s == PL_multi_open)
11699                     brackets++;
11700                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11701                     has_utf8 = TRUE;
11702                 *to = *s;
11703             }
11704         }
11705         /* terminate the copied string and update the sv's end-of-string */
11706         *to = '\0';
11707         SvCUR_set(sv, to - SvPVX_const(sv));
11708
11709         /*
11710          * this next chunk reads more into the buffer if we're not done yet
11711          */
11712
11713         if (s < PL_bufend)
11714             break;              /* handle case where we are done yet :-) */
11715
11716 #ifndef PERL_STRICT_CR
11717         if (to - SvPVX_const(sv) >= 2) {
11718             if ((to[-2] == '\r' && to[-1] == '\n') ||
11719                 (to[-2] == '\n' && to[-1] == '\r'))
11720             {
11721                 to[-2] = '\n';
11722                 to--;
11723                 SvCUR_set(sv, to - SvPVX_const(sv));
11724             }
11725             else if (to[-1] == '\r')
11726                 to[-1] = '\n';
11727         }
11728         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11729             to[-1] = '\n';
11730 #endif
11731
11732      read_more_line:
11733         /* if we're out of file, or a read fails, bail and reset the current
11734            line marker so we can report where the unterminated string began
11735         */
11736 #ifdef PERL_MAD
11737         if (PL_madskills) {
11738             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11739             if (PL_thisstuff)
11740                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11741             else
11742                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11743         }
11744 #endif
11745         if (!PL_rsfp ||
11746          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11747             sv_free(sv);
11748             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11749             return NULL;
11750         }
11751 #ifdef PERL_MAD
11752         stuffstart = 0;
11753 #endif
11754         /* we read a line, so increment our line counter */
11755         CopLINE_inc(PL_curcop);
11756
11757         /* update debugger info */
11758         if (PERLDB_LINE && PL_curstash != PL_debstash)
11759             update_debugger_info(PL_linestr, NULL, 0);
11760
11761         /* having changed the buffer, we must update PL_bufend */
11762         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11763         PL_last_lop = PL_last_uni = NULL;
11764     }
11765
11766     /* at this point, we have successfully read the delimited string */
11767
11768     if (!PL_encoding || UTF) {
11769 #ifdef PERL_MAD
11770         if (PL_madskills) {
11771             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11772             const int len = s - tstart;
11773             if (PL_thisstuff)
11774                 sv_catpvn(PL_thisstuff, tstart, len);
11775             else
11776                 PL_thisstuff = newSVpvn(tstart, len);
11777             if (!PL_thisclose && !keep_delims)
11778                 PL_thisclose = newSVpvn(s,termlen);
11779         }
11780 #endif
11781
11782         if (keep_delims)
11783             sv_catpvn(sv, s, termlen);
11784         s += termlen;
11785     }
11786 #ifdef PERL_MAD
11787     else {
11788         if (PL_madskills) {
11789             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11790             const int len = s - tstart - termlen;
11791             if (PL_thisstuff)
11792                 sv_catpvn(PL_thisstuff, tstart, len);
11793             else
11794                 PL_thisstuff = newSVpvn(tstart, len);
11795             if (!PL_thisclose && !keep_delims)
11796                 PL_thisclose = newSVpvn(s - termlen,termlen);
11797         }
11798     }
11799 #endif
11800     if (has_utf8 || PL_encoding)
11801         SvUTF8_on(sv);
11802
11803     PL_multi_end = CopLINE(PL_curcop);
11804
11805     /* if we allocated too much space, give some back */
11806     if (SvCUR(sv) + 5 < SvLEN(sv)) {
11807         SvLEN_set(sv, SvCUR(sv) + 1);
11808         SvPV_renew(sv, SvLEN(sv));
11809     }
11810
11811     /* decide whether this is the first or second quoted string we've read
11812        for this op
11813     */
11814
11815     if (PL_lex_stuff)
11816         PL_lex_repl = sv;
11817     else
11818         PL_lex_stuff = sv;
11819     return s;
11820 }
11821
11822 /*
11823   scan_num
11824   takes: pointer to position in buffer
11825   returns: pointer to new position in buffer
11826   side-effects: builds ops for the constant in yylval.op
11827
11828   Read a number in any of the formats that Perl accepts:
11829
11830   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
11831   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
11832   0b[01](_?[01])*
11833   0[0-7](_?[0-7])*
11834   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11835
11836   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11837   thing it reads.
11838
11839   If it reads a number without a decimal point or an exponent, it will
11840   try converting the number to an integer and see if it can do so
11841   without loss of precision.
11842 */
11843
11844 char *
11845 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11846 {
11847     dVAR;
11848     register const char *s = start;     /* current position in buffer */
11849     register char *d;                   /* destination in temp buffer */
11850     register char *e;                   /* end of temp buffer */
11851     NV nv;                              /* number read, as a double */
11852     SV *sv = NULL;                      /* place to put the converted number */
11853     bool floatit;                       /* boolean: int or float? */
11854     const char *lastub = NULL;          /* position of last underbar */
11855     static char const number_too_long[] = "Number too long";
11856
11857     /* We use the first character to decide what type of number this is */
11858
11859     switch (*s) {
11860     default:
11861       Perl_croak(aTHX_ "panic: scan_num");
11862
11863     /* if it starts with a 0, it could be an octal number, a decimal in
11864        0.13 disguise, or a hexadecimal number, or a binary number. */
11865     case '0':
11866         {
11867           /* variables:
11868              u          holds the "number so far"
11869              shift      the power of 2 of the base
11870                         (hex == 4, octal == 3, binary == 1)
11871              overflowed was the number more than we can hold?
11872
11873              Shift is used when we add a digit.  It also serves as an "are
11874              we in octal/hex/binary?" indicator to disallow hex characters
11875              when in octal mode.
11876            */
11877             NV n = 0.0;
11878             UV u = 0;
11879             I32 shift;
11880             bool overflowed = FALSE;
11881             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
11882             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11883             static const char* const bases[5] =
11884               { "", "binary", "", "octal", "hexadecimal" };
11885             static const char* const Bases[5] =
11886               { "", "Binary", "", "Octal", "Hexadecimal" };
11887             static const char* const maxima[5] =
11888               { "",
11889                 "0b11111111111111111111111111111111",
11890                 "",
11891                 "037777777777",
11892                 "0xffffffff" };
11893             const char *base, *Base, *max;
11894
11895             /* check for hex */
11896             if (s[1] == 'x') {
11897                 shift = 4;
11898                 s += 2;
11899                 just_zero = FALSE;
11900             } else if (s[1] == 'b') {
11901                 shift = 1;
11902                 s += 2;
11903                 just_zero = FALSE;
11904             }
11905             /* check for a decimal in disguise */
11906             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11907                 goto decimal;
11908             /* so it must be octal */
11909             else {
11910                 shift = 3;
11911                 s++;
11912             }
11913
11914             if (*s == '_') {
11915                if (ckWARN(WARN_SYNTAX))
11916                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11917                                "Misplaced _ in number");
11918                lastub = s++;
11919             }
11920
11921             base = bases[shift];
11922             Base = Bases[shift];
11923             max  = maxima[shift];
11924
11925             /* read the rest of the number */
11926             for (;;) {
11927                 /* x is used in the overflow test,
11928                    b is the digit we're adding on. */
11929                 UV x, b;
11930
11931                 switch (*s) {
11932
11933                 /* if we don't mention it, we're done */
11934                 default:
11935                     goto out;
11936
11937                 /* _ are ignored -- but warned about if consecutive */
11938                 case '_':
11939                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11940                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11941                                     "Misplaced _ in number");
11942                     lastub = s++;
11943                     break;
11944
11945                 /* 8 and 9 are not octal */
11946                 case '8': case '9':
11947                     if (shift == 3)
11948                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11949                     /* FALL THROUGH */
11950
11951                 /* octal digits */
11952                 case '2': case '3': case '4':
11953                 case '5': case '6': case '7':
11954                     if (shift == 1)
11955                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11956                     /* FALL THROUGH */
11957
11958                 case '0': case '1':
11959                     b = *s++ & 15;              /* ASCII digit -> value of digit */
11960                     goto digit;
11961
11962                 /* hex digits */
11963                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11964                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11965                     /* make sure they said 0x */
11966                     if (shift != 4)
11967                         goto out;
11968                     b = (*s++ & 7) + 9;
11969
11970                     /* Prepare to put the digit we have onto the end
11971                        of the number so far.  We check for overflows.
11972                     */
11973
11974                   digit:
11975                     just_zero = FALSE;
11976                     if (!overflowed) {
11977                         x = u << shift; /* make room for the digit */
11978
11979                         if ((x >> shift) != u
11980                             && !(PL_hints & HINT_NEW_BINARY)) {
11981                             overflowed = TRUE;
11982                             n = (NV) u;
11983                             if (ckWARN_d(WARN_OVERFLOW))
11984                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11985                                             "Integer overflow in %s number",
11986                                             base);
11987                         } else
11988                             u = x | b;          /* add the digit to the end */
11989                     }
11990                     if (overflowed) {
11991                         n *= nvshift[shift];
11992                         /* If an NV has not enough bits in its
11993                          * mantissa to represent an UV this summing of
11994                          * small low-order numbers is a waste of time
11995                          * (because the NV cannot preserve the
11996                          * low-order bits anyway): we could just
11997                          * remember when did we overflow and in the
11998                          * end just multiply n by the right
11999                          * amount. */
12000                         n += (NV) b;
12001                     }
12002                     break;
12003                 }
12004             }
12005
12006           /* if we get here, we had success: make a scalar value from
12007              the number.
12008           */
12009           out:
12010
12011             /* final misplaced underbar check */
12012             if (s[-1] == '_') {
12013                 if (ckWARN(WARN_SYNTAX))
12014                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12015             }
12016
12017             sv = newSV(0);
12018             if (overflowed) {
12019                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12020                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12021                                 "%s number > %s non-portable",
12022                                 Base, max);
12023                 sv_setnv(sv, n);
12024             }
12025             else {
12026 #if UVSIZE > 4
12027                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12028                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12029                                 "%s number > %s non-portable",
12030                                 Base, max);
12031 #endif
12032                 sv_setuv(sv, u);
12033             }
12034             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12035                 sv = new_constant(start, s - start, "integer",
12036                                   sv, NULL, NULL);
12037             else if (PL_hints & HINT_NEW_BINARY)
12038                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12039         }
12040         break;
12041
12042     /*
12043       handle decimal numbers.
12044       we're also sent here when we read a 0 as the first digit
12045     */
12046     case '1': case '2': case '3': case '4': case '5':
12047     case '6': case '7': case '8': case '9': case '.':
12048       decimal:
12049         d = PL_tokenbuf;
12050         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12051         floatit = FALSE;
12052
12053         /* read next group of digits and _ and copy into d */
12054         while (isDIGIT(*s) || *s == '_') {
12055             /* skip underscores, checking for misplaced ones
12056                if -w is on
12057             */
12058             if (*s == '_') {
12059                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12060                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12061                                 "Misplaced _ in number");
12062                 lastub = s++;
12063             }
12064             else {
12065                 /* check for end of fixed-length buffer */
12066                 if (d >= e)
12067                     Perl_croak(aTHX_ number_too_long);
12068                 /* if we're ok, copy the character */
12069                 *d++ = *s++;
12070             }
12071         }
12072
12073         /* final misplaced underbar check */
12074         if (lastub && s == lastub + 1) {
12075             if (ckWARN(WARN_SYNTAX))
12076                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12077         }
12078
12079         /* read a decimal portion if there is one.  avoid
12080            3..5 being interpreted as the number 3. followed
12081            by .5
12082         */
12083         if (*s == '.' && s[1] != '.') {
12084             floatit = TRUE;
12085             *d++ = *s++;
12086
12087             if (*s == '_') {
12088                 if (ckWARN(WARN_SYNTAX))
12089                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12090                                 "Misplaced _ in number");
12091                 lastub = s;
12092             }
12093
12094             /* copy, ignoring underbars, until we run out of digits.
12095             */
12096             for (; isDIGIT(*s) || *s == '_'; s++) {
12097                 /* fixed length buffer check */
12098                 if (d >= e)
12099                     Perl_croak(aTHX_ number_too_long);
12100                 if (*s == '_') {
12101                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12102                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12103                                    "Misplaced _ in number");
12104                    lastub = s;
12105                 }
12106                 else
12107                     *d++ = *s;
12108             }
12109             /* fractional part ending in underbar? */
12110             if (s[-1] == '_') {
12111                 if (ckWARN(WARN_SYNTAX))
12112                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12113                                 "Misplaced _ in number");
12114             }
12115             if (*s == '.' && isDIGIT(s[1])) {
12116                 /* oops, it's really a v-string, but without the "v" */
12117                 s = start;
12118                 goto vstring;
12119             }
12120         }
12121
12122         /* read exponent part, if present */
12123         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12124             floatit = TRUE;
12125             s++;
12126
12127             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12128             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
12129
12130             /* stray preinitial _ */
12131             if (*s == '_') {
12132                 if (ckWARN(WARN_SYNTAX))
12133                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12134                                 "Misplaced _ in number");
12135                 lastub = s++;
12136             }
12137
12138             /* allow positive or negative exponent */
12139             if (*s == '+' || *s == '-')
12140                 *d++ = *s++;
12141
12142             /* stray initial _ */
12143             if (*s == '_') {
12144                 if (ckWARN(WARN_SYNTAX))
12145                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12146                                 "Misplaced _ in number");
12147                 lastub = s++;
12148             }
12149
12150             /* read digits of exponent */
12151             while (isDIGIT(*s) || *s == '_') {
12152                 if (isDIGIT(*s)) {
12153                     if (d >= e)
12154                         Perl_croak(aTHX_ number_too_long);
12155                     *d++ = *s++;
12156                 }
12157                 else {
12158                    if (((lastub && s == lastub + 1) ||
12159                         (!isDIGIT(s[1]) && s[1] != '_'))
12160                     && ckWARN(WARN_SYNTAX))
12161                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12162                                    "Misplaced _ in number");
12163                    lastub = s++;
12164                 }
12165             }
12166         }
12167
12168
12169         /* make an sv from the string */
12170         sv = newSV(0);
12171
12172         /*
12173            We try to do an integer conversion first if no characters
12174            indicating "float" have been found.
12175          */
12176
12177         if (!floatit) {
12178             UV uv;
12179             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12180
12181             if (flags == IS_NUMBER_IN_UV) {
12182               if (uv <= IV_MAX)
12183                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12184               else
12185                 sv_setuv(sv, uv);
12186             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12187               if (uv <= (UV) IV_MIN)
12188                 sv_setiv(sv, -(IV)uv);
12189               else
12190                 floatit = TRUE;
12191             } else
12192               floatit = TRUE;
12193         }
12194         if (floatit) {
12195             /* terminate the string */
12196             *d = '\0';
12197             nv = Atof(PL_tokenbuf);
12198             sv_setnv(sv, nv);
12199         }
12200
12201         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12202                        (PL_hints & HINT_NEW_INTEGER) )
12203             sv = new_constant(PL_tokenbuf,
12204                               d - PL_tokenbuf,
12205                               (const char *)
12206                               (floatit ? "float" : "integer"),
12207                               sv, NULL, NULL);
12208         break;
12209
12210     /* if it starts with a v, it could be a v-string */
12211     case 'v':
12212 vstring:
12213                 sv = newSV(5); /* preallocate storage space */
12214                 s = scan_vstring(s,sv);
12215         break;
12216     }
12217
12218     /* make the op for the constant and return */
12219
12220     if (sv)
12221         lvalp->opval = newSVOP(OP_CONST, 0, sv);
12222     else
12223         lvalp->opval = NULL;
12224
12225     return (char *)s;
12226 }
12227
12228 STATIC char *
12229 S_scan_formline(pTHX_ register char *s)
12230 {
12231     dVAR;
12232     register char *eol;
12233     register char *t;
12234     SV * const stuff = newSVpvs("");
12235     bool needargs = FALSE;
12236     bool eofmt = FALSE;
12237 #ifdef PERL_MAD
12238     char *tokenstart = s;
12239     SV* savewhite;
12240
12241     if (PL_madskills) {
12242         savewhite = PL_thiswhite;
12243         PL_thiswhite = 0;
12244     }
12245 #endif
12246
12247     while (!needargs) {
12248         if (*s == '.') {
12249             t = s+1;
12250 #ifdef PERL_STRICT_CR
12251             while (SPACE_OR_TAB(*t))
12252                 t++;
12253 #else
12254             while (SPACE_OR_TAB(*t) || *t == '\r')
12255                 t++;
12256 #endif
12257             if (*t == '\n' || t == PL_bufend) {
12258                 eofmt = TRUE;
12259                 break;
12260             }
12261         }
12262         if (PL_in_eval && !PL_rsfp) {
12263             eol = (char *) memchr(s,'\n',PL_bufend-s);
12264             if (!eol++)
12265                 eol = PL_bufend;
12266         }
12267         else
12268             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12269         if (*s != '#') {
12270             for (t = s; t < eol; t++) {
12271                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12272                     needargs = FALSE;
12273                     goto enough;        /* ~~ must be first line in formline */
12274                 }
12275                 if (*t == '@' || *t == '^')
12276                     needargs = TRUE;
12277             }
12278             if (eol > s) {
12279                 sv_catpvn(stuff, s, eol-s);
12280 #ifndef PERL_STRICT_CR
12281                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12282                     char *end = SvPVX(stuff) + SvCUR(stuff);
12283                     end[-2] = '\n';
12284                     end[-1] = '\0';
12285                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12286                 }
12287 #endif
12288             }
12289             else
12290               break;
12291         }
12292         s = (char*)eol;
12293         if (PL_rsfp) {
12294 #ifdef PERL_MAD
12295             if (PL_madskills) {
12296                 if (PL_thistoken)
12297                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12298                 else
12299                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12300             }
12301 #endif
12302             s = filter_gets(PL_linestr, PL_rsfp, 0);
12303 #ifdef PERL_MAD
12304             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12305 #else
12306             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12307 #endif
12308             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12309             PL_last_lop = PL_last_uni = NULL;
12310             if (!s) {
12311                 s = PL_bufptr;
12312                 break;
12313             }
12314         }
12315         incline(s);
12316     }
12317   enough:
12318     if (SvCUR(stuff)) {
12319         PL_expect = XTERM;
12320         if (needargs) {
12321             PL_lex_state = LEX_NORMAL;
12322             start_force(PL_curforce);
12323             NEXTVAL_NEXTTOKE.ival = 0;
12324             force_next(',');
12325         }
12326         else
12327             PL_lex_state = LEX_FORMLINE;
12328         if (!IN_BYTES) {
12329             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12330                 SvUTF8_on(stuff);
12331             else if (PL_encoding)
12332                 sv_recode_to_utf8(stuff, PL_encoding);
12333         }
12334         start_force(PL_curforce);
12335         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12336         force_next(THING);
12337         start_force(PL_curforce);
12338         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12339         force_next(LSTOP);
12340     }
12341     else {
12342         SvREFCNT_dec(stuff);
12343         if (eofmt)
12344             PL_lex_formbrack = 0;
12345         PL_bufptr = s;
12346     }
12347 #ifdef PERL_MAD
12348     if (PL_madskills) {
12349         if (PL_thistoken)
12350             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12351         else
12352             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12353         PL_thiswhite = savewhite;
12354     }
12355 #endif
12356     return s;
12357 }
12358
12359 STATIC void
12360 S_set_csh(pTHX)
12361 {
12362 #ifdef CSH
12363     dVAR;
12364     if (!PL_cshlen)
12365         PL_cshlen = strlen(PL_cshname);
12366 #else
12367 #if defined(USE_ITHREADS)
12368     PERL_UNUSED_CONTEXT;
12369 #endif
12370 #endif
12371 }
12372
12373 I32
12374 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12375 {
12376     dVAR;
12377     const I32 oldsavestack_ix = PL_savestack_ix;
12378     CV* const outsidecv = PL_compcv;
12379
12380     if (PL_compcv) {
12381         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12382     }
12383     SAVEI32(PL_subline);
12384     save_item(PL_subname);
12385     SAVESPTR(PL_compcv);
12386
12387     PL_compcv = (CV*)newSV(0);
12388     sv_upgrade((SV *)PL_compcv, 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  */