toke.c

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