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