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