toke.c

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