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