toke.c

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