toke.c

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