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