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