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