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