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