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