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