toke.c

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