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