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