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