toke.c

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