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                     }
2997                 }
2998             }
2999         }
3000         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3001             PL_bufptr = s;
3002             PL_lex_state = LEX_FORMLINE;
3003             return yylex();
3004         }
3005         goto retry;
3006     case '\r':
3007 #ifdef PERL_STRICT_CR
3008         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3009         Perl_croak(aTHX_
3010       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3011 #endif
3012     case ' ': case '\t': case '\f': case 013:
3013 #ifdef MACOS_TRADITIONAL
3014     case '\312':
3015 #endif
3016         s++;
3017         goto retry;
3018     case '#':
3019     case '\n':
3020         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3021             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3022                 /* handle eval qq[#line 1 "foo"\n ...] */
3023                 CopLINE_dec(PL_curcop);
3024                 incline(s);
3025             }
3026             d = PL_bufend;
3027             while (s < d && *s != '\n')
3028                 s++;
3029             if (s < d)
3030                 s++;
3031             else if (s > d) /* Found by Ilya: feed random input to Perl. */
3032               Perl_croak(aTHX_ "panic: input overflow");
3033             incline(s);
3034             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3035                 PL_bufptr = s;
3036                 PL_lex_state = LEX_FORMLINE;
3037                 return yylex();
3038             }
3039         }
3040         else {
3041             *s = '\0';
3042             PL_bufend = s;
3043         }
3044         goto retry;
3045     case '-':
3046         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3047             I32 ftst = 0;
3048             char tmp;
3049
3050             s++;
3051             PL_bufptr = s;
3052             tmp = *s++;
3053
3054             while (s < PL_bufend && SPACE_OR_TAB(*s))
3055                 s++;
3056
3057             if (strnEQ(s,"=>",2)) {
3058                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3059                 DEBUG_T( { S_printbuf(aTHX_
3060                         "### Saw unary minus before =>, forcing word %s\n", s);
3061                 } );
3062                 OPERATOR('-');          /* unary minus */
3063             }
3064             PL_last_uni = PL_oldbufptr;
3065             switch (tmp) {
3066             case 'r': ftst = OP_FTEREAD;        break;
3067             case 'w': ftst = OP_FTEWRITE;       break;
3068             case 'x': ftst = OP_FTEEXEC;        break;
3069             case 'o': ftst = OP_FTEOWNED;       break;
3070             case 'R': ftst = OP_FTRREAD;        break;
3071             case 'W': ftst = OP_FTRWRITE;       break;
3072             case 'X': ftst = OP_FTREXEC;        break;
3073             case 'O': ftst = OP_FTROWNED;       break;
3074             case 'e': ftst = OP_FTIS;           break;
3075             case 'z': ftst = OP_FTZERO;         break;
3076             case 's': ftst = OP_FTSIZE;         break;
3077             case 'f': ftst = OP_FTFILE;         break;
3078             case 'd': ftst = OP_FTDIR;          break;
3079             case 'l': ftst = OP_FTLINK;         break;
3080             case 'p': ftst = OP_FTPIPE;         break;
3081             case 'S': ftst = OP_FTSOCK;         break;
3082             case 'u': ftst = OP_FTSUID;         break;
3083             case 'g': ftst = OP_FTSGID;         break;
3084             case 'k': ftst = OP_FTSVTX;         break;
3085             case 'b': ftst = OP_FTBLK;          break;
3086             case 'c': ftst = OP_FTCHR;          break;
3087             case 't': ftst = OP_FTTTY;          break;
3088             case 'T': ftst = OP_FTTEXT;         break;
3089             case 'B': ftst = OP_FTBINARY;       break;
3090             case 'M': case 'A': case 'C':
3091                 gv_fetchpv("\024",GV_ADD, SVt_PV);
3092                 switch (tmp) {
3093                 case 'M': ftst = OP_FTMTIME;    break;
3094                 case 'A': ftst = OP_FTATIME;    break;
3095                 case 'C': ftst = OP_FTCTIME;    break;
3096                 default:                        break;
3097                 }
3098                 break;
3099             default:
3100                 break;
3101             }
3102             if (ftst) {
3103                 PL_last_lop_op = (OPCODE)ftst;
3104                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3105                         "### Saw file test %c\n", (int)tmp);
3106                 } );
3107                 FTST(ftst);
3108             }
3109             else {
3110                 /* Assume it was a minus followed by a one-letter named
3111                  * subroutine call (or a -bareword), then. */
3112                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3113                         "### '-%c' looked like a file test but was not\n",
3114                         (int) tmp);
3115                 } );
3116                 s = --PL_bufptr;
3117             }
3118         }
3119         {
3120             const char tmp = *s++;
3121             if (*s == tmp) {
3122                 s++;
3123                 if (PL_expect == XOPERATOR)
3124                     TERM(POSTDEC);
3125                 else
3126                     OPERATOR(PREDEC);
3127             }
3128             else if (*s == '>') {
3129                 s++;
3130                 s = skipspace(s);
3131                 if (isIDFIRST_lazy_if(s,UTF)) {
3132                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3133                     TOKEN(ARROW);
3134                 }
3135                 else if (*s == '$')
3136                     OPERATOR(ARROW);
3137                 else
3138                     TERM(ARROW);
3139             }
3140             if (PL_expect == XOPERATOR)
3141                 Aop(OP_SUBTRACT);
3142             else {
3143                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3144                     check_uni();
3145                 OPERATOR('-');          /* unary minus */
3146             }
3147         }
3148
3149     case '+':
3150         {
3151             const char tmp = *s++;
3152             if (*s == tmp) {
3153                 s++;
3154                 if (PL_expect == XOPERATOR)
3155                     TERM(POSTINC);
3156                 else
3157                     OPERATOR(PREINC);
3158             }
3159             if (PL_expect == XOPERATOR)
3160                 Aop(OP_ADD);
3161             else {
3162                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3163                     check_uni();
3164                 OPERATOR('+');
3165             }
3166         }
3167
3168     case '*':
3169         if (PL_expect != XOPERATOR) {
3170             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3171             PL_expect = XOPERATOR;
3172             force_ident(PL_tokenbuf, '*');
3173             if (!*PL_tokenbuf)
3174                 PREREF('*');
3175             TERM('*');
3176         }
3177         s++;
3178         if (*s == '*') {
3179             s++;
3180             PWop(OP_POW);
3181         }
3182         Mop(OP_MULTIPLY);
3183
3184     case '%':
3185         if (PL_expect == XOPERATOR) {
3186             ++s;
3187             Mop(OP_MODULO);
3188         }
3189         PL_tokenbuf[0] = '%';
3190         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3191         if (!PL_tokenbuf[1]) {
3192             PREREF('%');
3193         }
3194         PL_pending_ident = '%';
3195         TERM('%');
3196
3197     case '^':
3198         s++;
3199         BOop(OP_BIT_XOR);
3200     case '[':
3201         PL_lex_brackets++;
3202         /* FALL THROUGH */
3203     case '~':
3204         if (s[1] == '~'
3205         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
3206         && FEATURE_IS_ENABLED("~~"))
3207         {
3208             s += 2;
3209             Eop(OP_SMARTMATCH);
3210         }
3211     case ',':
3212         {
3213             const char tmp = *s++;
3214             OPERATOR(tmp);
3215         }
3216     case ':':
3217         if (s[1] == ':') {
3218             len = 0;
3219             goto just_a_word_zero_gv;
3220         }
3221         s++;
3222         switch (PL_expect) {
3223             OP *attrs;
3224         case XOPERATOR:
3225             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3226                 break;
3227             PL_bufptr = s;      /* update in case we back off */
3228             goto grabattrs;
3229         case XATTRBLOCK:
3230             PL_expect = XBLOCK;
3231             goto grabattrs;
3232         case XATTRTERM:
3233             PL_expect = XTERMBLOCK;
3234          grabattrs:
3235             s = skipspace(s);
3236             attrs = Nullop;
3237             while (isIDFIRST_lazy_if(s,UTF)) {
3238                 I32 tmp;
3239                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3240                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3241                     if (tmp < 0) tmp = -tmp;
3242                     switch (tmp) {
3243                     case KEY_or:
3244                     case KEY_and:
3245                     case KEY_err:
3246                     case KEY_for:
3247                     case KEY_unless:
3248                     case KEY_if:
3249                     case KEY_while:
3250                     case KEY_until:
3251                         goto got_attrs;
3252                     default:
3253                         break;
3254                     }
3255                 }
3256                 if (*d == '(') {
3257                     d = scan_str(d,TRUE,TRUE);
3258                     if (!d) {
3259                         /* MUST advance bufptr here to avoid bogus
3260                            "at end of line" context messages from yyerror().
3261                          */
3262                         PL_bufptr = s + len;
3263                         yyerror("Unterminated attribute parameter in attribute list");
3264                         if (attrs)
3265                             op_free(attrs);
3266                         return REPORT(0);       /* EOF indicator */
3267                     }
3268                 }
3269                 if (PL_lex_stuff) {
3270                     SV *sv = newSVpvn(s, len);
3271                     sv_catsv(sv, PL_lex_stuff);
3272                     attrs = append_elem(OP_LIST, attrs,
3273                                         newSVOP(OP_CONST, 0, sv));
3274                     SvREFCNT_dec(PL_lex_stuff);
3275                     PL_lex_stuff = Nullsv;
3276                 }
3277                 else {
3278                     if (len == 6 && strnEQ(s, "unique", len)) {
3279                         if (PL_in_my == KEY_our)
3280 #ifdef USE_ITHREADS
3281                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3282 #else
3283                             ; /* skip to avoid loading attributes.pm */
3284 #endif
3285                         else
3286                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3287                     }
3288
3289                     /* NOTE: any CV attrs applied here need to be part of
3290                        the CVf_BUILTIN_ATTRS define in cv.h! */
3291                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3292                         CvLVALUE_on(PL_compcv);
3293                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3294                         CvLOCKED_on(PL_compcv);
3295                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3296                         CvMETHOD_on(PL_compcv);
3297                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3298                         CvASSERTION_on(PL_compcv);
3299                     /* After we've set the flags, it could be argued that
3300                        we don't need to do the attributes.pm-based setting
3301                        process, and shouldn't bother appending recognized
3302                        flags.  To experiment with that, uncomment the
3303                        following "else".  (Note that's already been
3304                        uncommented.  That keeps the above-applied built-in
3305                        attributes from being intercepted (and possibly
3306                        rejected) by a package's attribute routines, but is
3307                        justified by the performance win for the common case
3308                        of applying only built-in attributes.) */
3309                     else
3310                         attrs = append_elem(OP_LIST, attrs,
3311                                             newSVOP(OP_CONST, 0,
3312                                                     newSVpvn(s, len)));
3313                 }
3314                 s = skipspace(d);
3315                 if (*s == ':' && s[1] != ':')
3316                     s = skipspace(s+1);
3317                 else if (s == d)
3318                     break;      /* require real whitespace or :'s */
3319             }
3320             {
3321                 const char tmp
3322                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3323                 if (*s != ';' && *s != '}' && *s != tmp
3324                     && (tmp != '=' || *s != ')')) {
3325                     const char q = ((*s == '\'') ? '"' : '\'');
3326                     /* If here for an expression, and parsed no attrs, back
3327                        off. */
3328                     if (tmp == '=' && !attrs) {
3329                         s = PL_bufptr;
3330                         break;
3331                     }
3332                     /* MUST advance bufptr here to avoid bogus "at end of line"
3333                        context messages from yyerror().
3334                     */
3335                     PL_bufptr = s;
3336                     yyerror( *s
3337                              ? Perl_form(aTHX_ "Invalid separator character "
3338                                          "%c%c%c in attribute list", q, *s, q)
3339                              : "Unterminated attribute list" );
3340                     if (attrs)
3341                         op_free(attrs);
3342                     OPERATOR(':');
3343                 }
3344             }
3345         got_attrs:
3346             if (attrs) {
3347                 PL_nextval[PL_nexttoke].opval = attrs;
3348                 force_next(THING);
3349             }
3350             TOKEN(COLONATTR);
3351         }
3352         OPERATOR(':');
3353     case '(':
3354         s++;
3355         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3356             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3357         else
3358             PL_expect = XTERM;
3359         s = skipspace(s);
3360         TOKEN('(');
3361     case ';':
3362         CLINE;
3363         {
3364             const char tmp = *s++;
3365             OPERATOR(tmp);
3366         }
3367     case ')':
3368         {
3369             const char tmp = *s++;
3370             s = skipspace(s);
3371             if (*s == '{')
3372                 PREBLOCK(tmp);
3373             TERM(tmp);
3374         }
3375     case ']':
3376         s++;
3377         if (PL_lex_brackets <= 0)
3378             yyerror("Unmatched right square bracket");
3379         else
3380             --PL_lex_brackets;
3381         if (PL_lex_state == LEX_INTERPNORMAL) {
3382             if (PL_lex_brackets == 0) {
3383                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3384                     PL_lex_state = LEX_INTERPEND;
3385             }
3386         }
3387         TERM(']');
3388     case '{':
3389       leftbracket:
3390         s++;
3391         if (PL_lex_brackets > 100) {
3392             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3393         }
3394         switch (PL_expect) {
3395         case XTERM:
3396             if (PL_lex_formbrack) {
3397                 s--;
3398                 PRETERMBLOCK(DO);
3399             }
3400             if (PL_oldoldbufptr == PL_last_lop)
3401                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3402             else
3403                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3404             OPERATOR(HASHBRACK);
3405         case XOPERATOR:
3406             while (s < PL_bufend && SPACE_OR_TAB(*s))
3407                 s++;
3408             d = s;
3409             PL_tokenbuf[0] = '\0';
3410             if (d < PL_bufend && *d == '-') {
3411                 PL_tokenbuf[0] = '-';
3412                 d++;
3413                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3414                     d++;
3415             }
3416             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3417                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3418                               FALSE, &len);
3419                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3420                     d++;
3421                 if (*d == '}') {
3422                     const char minus = (PL_tokenbuf[0] == '-');
3423                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3424                     if (minus)
3425                         force_next('-');
3426                 }
3427             }
3428             /* FALL THROUGH */
3429         case XATTRBLOCK:
3430         case XBLOCK:
3431             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3432             PL_expect = XSTATE;
3433             break;
3434         case XATTRTERM:
3435         case XTERMBLOCK:
3436             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3437             PL_expect = XSTATE;
3438             break;
3439         default: {
3440                 const char *t;
3441                 if (PL_oldoldbufptr == PL_last_lop)
3442                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3443                 else
3444                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3445                 s = skipspace(s);
3446                 if (*s == '}') {
3447                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3448                         PL_expect = XTERM;
3449                         /* This hack is to get the ${} in the message. */
3450                         PL_bufptr = s+1;
3451                         yyerror("syntax error");
3452                         break;
3453                     }
3454                     OPERATOR(HASHBRACK);
3455                 }
3456                 /* This hack serves to disambiguate a pair of curlies
3457                  * as being a block or an anon hash.  Normally, expectation
3458                  * determines that, but in cases where we're not in a
3459                  * position to expect anything in particular (like inside
3460                  * eval"") we have to resolve the ambiguity.  This code
3461                  * covers the case where the first term in the curlies is a
3462                  * quoted string.  Most other cases need to be explicitly
3463                  * disambiguated by prepending a "+" before the opening
3464                  * curly in order to force resolution as an anon hash.
3465                  *
3466                  * XXX should probably propagate the outer expectation
3467                  * into eval"" to rely less on this hack, but that could
3468                  * potentially break current behavior of eval"".
3469                  * GSAR 97-07-21
3470                  */
3471                 t = s;
3472                 if (*s == '\'' || *s == '"' || *s == '`') {
3473                     /* common case: get past first string, handling escapes */
3474                     for (t++; t < PL_bufend && *t != *s;)
3475                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3476                             t++;
3477                     t++;
3478                 }
3479                 else if (*s == 'q') {
3480                     if (++t < PL_bufend
3481                         && (!isALNUM(*t)
3482                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3483                                 && !isALNUM(*t))))
3484                     {
3485                         /* skip q//-like construct */
3486                         const char *tmps;
3487                         char open, close, term;
3488                         I32 brackets = 1;
3489
3490                         while (t < PL_bufend && isSPACE(*t))
3491                             t++;
3492                         /* check for q => */
3493                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3494                             OPERATOR(HASHBRACK);
3495                         }
3496                         term = *t;
3497                         open = term;
3498                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3499                             term = tmps[5];
3500                         close = term;
3501                         if (open == close)
3502                             for (t++; t < PL_bufend; t++) {
3503                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3504                                     t++;
3505                                 else if (*t == open)
3506                                     break;
3507                             }
3508                         else {
3509                             for (t++; t < PL_bufend; t++) {
3510                                 if (*t == '\\' && t+1 < PL_bufend)
3511                                     t++;
3512                                 else if (*t == close && --brackets <= 0)
3513                                     break;
3514                                 else if (*t == open)
3515                                     brackets++;
3516                             }
3517                         }
3518                         t++;
3519                     }
3520                     else
3521                         /* skip plain q word */
3522                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3523                              t += UTF8SKIP(t);
3524                 }
3525                 else if (isALNUM_lazy_if(t,UTF)) {
3526                     t += UTF8SKIP(t);
3527                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3528                          t += UTF8SKIP(t);
3529                 }
3530                 while (t < PL_bufend && isSPACE(*t))
3531                     t++;
3532                 /* if comma follows first term, call it an anon hash */
3533                 /* XXX it could be a comma expression with loop modifiers */
3534                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3535                                    || (*t == '=' && t[1] == '>')))
3536                     OPERATOR(HASHBRACK);
3537                 if (PL_expect == XREF)
3538                     PL_expect = XTERM;
3539                 else {
3540                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3541                     PL_expect = XSTATE;
3542                 }
3543             }
3544             break;
3545         }
3546         yylval.ival = CopLINE(PL_curcop);
3547         if (isSPACE(*s) || *s == '#')
3548             PL_copline = NOLINE;   /* invalidate current command line number */
3549         TOKEN('{');
3550     case '}':
3551       rightbracket:
3552         s++;
3553         if (PL_lex_brackets <= 0)
3554             yyerror("Unmatched right curly bracket");
3555         else
3556             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3557         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3558             PL_lex_formbrack = 0;
3559         if (PL_lex_state == LEX_INTERPNORMAL) {
3560             if (PL_lex_brackets == 0) {
3561                 if (PL_expect & XFAKEBRACK) {
3562                     PL_expect &= XENUMMASK;
3563                     PL_lex_state = LEX_INTERPEND;
3564                     PL_bufptr = s;
3565                     return yylex();     /* ignore fake brackets */
3566                 }
3567                 if (*s == '-' && s[1] == '>')
3568                     PL_lex_state = LEX_INTERPENDMAYBE;
3569                 else if (*s != '[' && *s != '{')
3570                     PL_lex_state = LEX_INTERPEND;
3571             }
3572         }
3573         if (PL_expect & XFAKEBRACK) {
3574             PL_expect &= XENUMMASK;
3575             PL_bufptr = s;
3576             return yylex();             /* ignore fake brackets */
3577         }
3578         force_next('}');
3579         TOKEN(';');
3580     case '&':
3581         s++;
3582         if (*s++ == '&')
3583             AOPERATOR(ANDAND);
3584         s--;
3585         if (PL_expect == XOPERATOR) {
3586             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3587                 && isIDFIRST_lazy_if(s,UTF))
3588             {
3589                 CopLINE_dec(PL_curcop);
3590                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3591                 CopLINE_inc(PL_curcop);
3592             }
3593             BAop(OP_BIT_AND);
3594         }
3595
3596         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3597         if (*PL_tokenbuf) {
3598             PL_expect = XOPERATOR;
3599             force_ident(PL_tokenbuf, '&');
3600         }
3601         else
3602             PREREF('&');
3603         yylval.ival = (OPpENTERSUB_AMPER<<8);
3604         TERM('&');
3605
3606     case '|':
3607         s++;
3608         if (*s++ == '|')
3609             AOPERATOR(OROR);
3610         s--;
3611         BOop(OP_BIT_OR);
3612     case '=':
3613         s++;
3614         {
3615             const char tmp = *s++;
3616             if (tmp == '=')
3617                 Eop(OP_EQ);
3618             if (tmp == '>')
3619                 OPERATOR(',');
3620             if (tmp == '~')
3621                 PMop(OP_MATCH);
3622             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
3623                 && strchr("+-*/%.^&|<",tmp))
3624                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3625                             "Reversed %c= operator",(int)tmp);
3626             s--;
3627             if (PL_expect == XSTATE && isALPHA(tmp) &&
3628                 (s == PL_linestart+1 || s[-2] == '\n') )
3629                 {
3630                     if (PL_in_eval && !PL_rsfp) {
3631                         d = PL_bufend;
3632                         while (s < d) {
3633                             if (*s++ == '\n') {
3634                                 incline(s);
3635                                 if (strnEQ(s,"=cut",4)) {
3636                                     s = strchr(s,'\n');
3637                                     if (s)
3638                                         s++;
3639                                     else
3640                                         s = d;
3641                                     incline(s);
3642                                     goto retry;
3643                                 }
3644                             }
3645                         }
3646                         goto retry;
3647                     }
3648                     s = PL_bufend;
3649                     PL_doextract = TRUE;
3650                     goto retry;
3651                 }
3652         }
3653         if (PL_lex_brackets < PL_lex_formbrack) {
3654             const char *t;
3655 #ifdef PERL_STRICT_CR
3656             for (t = s; SPACE_OR_TAB(*t); t++) ;
3657 #else
3658             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3659 #endif
3660             if (*t == '\n' || *t == '#') {
3661                 s--;
3662                 PL_expect = XBLOCK;
3663                 goto leftbracket;
3664             }
3665         }
3666         yylval.ival = 0;
3667         OPERATOR(ASSIGNOP);
3668     case '!':
3669         s++;
3670         {
3671             const char tmp = *s++;
3672             if (tmp == '=') {
3673                 /* was this !=~ where !~ was meant?
3674                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3675
3676                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3677                     const char *t = s+1;
3678
3679                     while (t < PL_bufend && isSPACE(*t))
3680                         ++t;
3681
3682                     if (*t == '/' || *t == '?' ||
3683                         ((*t == 'm' || *t == 's' || *t == 'y')
3684                          && !isALNUM(t[1])) ||
3685                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3686                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3687                                     "!=~ should be !~");
3688                 }
3689                 Eop(OP_NE);
3690             }
3691             if (tmp == '~')
3692                 PMop(OP_NOT);
3693         }
3694         s--;
3695         OPERATOR('!');
3696     case '<':
3697         if (PL_expect != XOPERATOR) {
3698             if (s[1] != '<' && !strchr(s,'>'))
3699                 check_uni();
3700             if (s[1] == '<')
3701                 s = scan_heredoc(s);
3702             else
3703                 s = scan_inputsymbol(s);
3704             TERM(sublex_start());
3705         }
3706         s++;
3707         {
3708             char tmp = *s++;
3709             if (tmp == '<')
3710                 SHop(OP_LEFT_SHIFT);
3711             if (tmp == '=') {
3712                 tmp = *s++;
3713                 if (tmp == '>')
3714                     Eop(OP_NCMP);
3715                 s--;
3716                 Rop(OP_LE);
3717             }
3718         }
3719         s--;
3720         Rop(OP_LT);
3721     case '>':
3722         s++;
3723         {
3724             const char tmp = *s++;
3725             if (tmp == '>')
3726                 SHop(OP_RIGHT_SHIFT);
3727             if (tmp == '=')
3728                 Rop(OP_GE);
3729         }
3730         s--;
3731         Rop(OP_GT);
3732
3733     case '$':
3734         CLINE;
3735
3736         if (PL_expect == XOPERATOR) {
3737             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3738                 PL_expect = XTERM;
3739                 deprecate_old(commaless_variable_list);
3740                 return REPORT(','); /* grandfather non-comma-format format */
3741             }
3742         }
3743
3744         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3745             PL_tokenbuf[0] = '@';
3746             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3747                            sizeof PL_tokenbuf - 1, FALSE);
3748             if (PL_expect == XOPERATOR)
3749                 no_op("Array length", s);
3750             if (!PL_tokenbuf[1])
3751                 PREREF(DOLSHARP);
3752             PL_expect = XOPERATOR;
3753             PL_pending_ident = '#';
3754             TOKEN(DOLSHARP);
3755         }
3756
3757         PL_tokenbuf[0] = '$';
3758         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3759                        sizeof PL_tokenbuf - 1, FALSE);
3760         if (PL_expect == XOPERATOR)
3761             no_op("Scalar", s);
3762         if (!PL_tokenbuf[1]) {
3763             if (s == PL_bufend)
3764                 yyerror("Final $ should be \\$ or $name");
3765             PREREF('$');
3766         }
3767
3768         /* This kludge not intended to be bulletproof. */
3769         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3770             yylval.opval = newSVOP(OP_CONST, 0,
3771                                    newSViv(PL_compiling.cop_arybase));
3772             yylval.opval->op_private = OPpCONST_ARYBASE;
3773             TERM(THING);
3774         }
3775
3776         d = s;
3777         {
3778             const char tmp = *s;
3779             if (PL_lex_state == LEX_NORMAL)
3780                 s = skipspace(s);
3781
3782             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
3783                 && intuit_more(s)) {
3784                 if (*s == '[') {
3785                     PL_tokenbuf[0] = '@';
3786                     if (ckWARN(WARN_SYNTAX)) {
3787                         char *t;
3788                         for(t = s + 1;
3789                             isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3790                             t++) ;
3791                         if (*t++ == ',') {
3792                             PL_bufptr = skipspace(PL_bufptr);
3793                             while (t < PL_bufend && *t != ']')
3794                                 t++;
3795                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3796                                         "Multidimensional syntax %.*s not supported",
3797                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
3798                         }
3799                     }
3800                 }
3801                 else if (*s == '{') {
3802                     char *t;
3803                     PL_tokenbuf[0] = '%';
3804                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
3805                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3806                         {
3807                             char tmpbuf[sizeof PL_tokenbuf];
3808                             for (t++; isSPACE(*t); t++) ;
3809                             if (isIDFIRST_lazy_if(t,UTF)) {
3810                                 STRLEN len;
3811                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
3812                                               &len);
3813                                 for (; isSPACE(*t); t++) ;
3814                                 if (*t == ';' && get_cv(tmpbuf, FALSE))
3815                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3816                                                 "You need to quote \"%s\"",
3817                                                 tmpbuf);
3818                             }
3819                         }
3820                 }
3821             }
3822
3823             PL_expect = XOPERATOR;
3824             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3825                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3826                 if (!islop || PL_last_lop_op == OP_GREPSTART)
3827                     PL_expect = XOPERATOR;
3828                 else if (strchr("$@\"'`q", *s))
3829                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
3830                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3831                     PL_expect = XTERM;          /* e.g. print $fh &sub */
3832                 else if (isIDFIRST_lazy_if(s,UTF)) {
3833                     char tmpbuf[sizeof PL_tokenbuf];
3834                     int t2;
3835                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3836                     if ((t2 = keyword(tmpbuf, len))) {
3837                         /* binary operators exclude handle interpretations */
3838                         switch (t2) {
3839                         case -KEY_x:
3840                         case -KEY_eq:
3841                         case -KEY_ne:
3842                         case -KEY_gt:
3843                         case -KEY_lt:
3844                         case -KEY_ge:
3845                         case -KEY_le:
3846                         case -KEY_cmp:
3847                             break;
3848                         default:
3849                             PL_expect = XTERM;  /* e.g. print $fh length() */
3850                             break;
3851                         }
3852                     }
3853                     else {
3854                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3855                     }
3856                 }
3857                 else if (isDIGIT(*s))
3858                     PL_expect = XTERM;          /* e.g. print $fh 3 */
3859                 else if (*s == '.' && isDIGIT(s[1]))
3860                     PL_expect = XTERM;          /* e.g. print $fh .3 */
3861                 else if ((*s == '?' || *s == '-' || *s == '+')
3862                          && !isSPACE(s[1]) && s[1] != '=')
3863                     PL_expect = XTERM;          /* e.g. print $fh -1 */
3864                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
3865                          && s[1] != '/')
3866                     PL_expect = XTERM;          /* e.g. print $fh /.../
3867                                                    XXX except DORDOR operator
3868                                                 */
3869                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
3870                          && s[2] != '=')
3871                     PL_expect = XTERM;          /* print $fh <<"EOF" */
3872             }
3873         }
3874         PL_pending_ident = '$';
3875         TOKEN('$');
3876
3877     case '@':
3878         if (PL_expect == XOPERATOR)
3879             no_op("Array", s);
3880         PL_tokenbuf[0] = '@';
3881         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3882         if (!PL_tokenbuf[1]) {
3883             PREREF('@');
3884         }
3885         if (PL_lex_state == LEX_NORMAL)
3886             s = skipspace(s);
3887         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3888             if (*s == '{')
3889                 PL_tokenbuf[0] = '%';
3890
3891             /* Warn about @ where they meant $. */
3892             if (*s == '[' || *s == '{') {
3893                 if (ckWARN(WARN_SYNTAX)) {
3894                     const char *t = s + 1;
3895                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3896                         t++;
3897                     if (*t == '}' || *t == ']') {
3898                         t++;
3899                         PL_bufptr = skipspace(PL_bufptr);
3900                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3901                             "Scalar value %.*s better written as $%.*s",
3902                             (int)(t-PL_bufptr), PL_bufptr,
3903                             (int)(t-PL_bufptr-1), PL_bufptr+1);
3904                     }
3905                 }
3906             }
3907         }
3908         PL_pending_ident = '@';
3909         TERM('@');
3910
3911      case '/':                  /* may be division, defined-or, or pattern */
3912         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3913             s += 2;
3914             AOPERATOR(DORDOR);
3915         }
3916      case '?':                  /* may either be conditional or pattern */
3917          if(PL_expect == XOPERATOR) {
3918              char tmp = *s++;
3919              if(tmp == '?') {
3920                   OPERATOR('?');
3921              }
3922              else {
3923                  tmp = *s++;
3924                  if(tmp == '/') {
3925                      /* A // operator. */
3926                     AOPERATOR(DORDOR);
3927                  }
3928                  else {
3929                      s--;
3930                      Mop(OP_DIVIDE);
3931                  }
3932              }
3933          }
3934          else {
3935              /* Disable warning on "study /blah/" */
3936              if (PL_oldoldbufptr == PL_last_uni
3937               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3938                   || memNE(PL_last_uni, "study", 5)
3939                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3940               ))
3941                  check_uni();
3942              s = scan_pat(s,OP_MATCH);
3943              TERM(sublex_start());
3944          }
3945
3946     case '.':
3947         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3948 #ifdef PERL_STRICT_CR
3949             && s[1] == '\n'
3950 #else
3951             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3952 #endif
3953             && (s == PL_linestart || s[-1] == '\n') )
3954         {
3955             PL_lex_formbrack = 0;
3956             PL_expect = XSTATE;
3957             goto rightbracket;
3958         }
3959         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3960             char tmp = *s++;
3961             if (*s == tmp) {
3962                 s++;
3963                 if (*s == tmp) {
3964                     s++;
3965                     yylval.ival = OPf_SPECIAL;
3966                 }
3967                 else
3968                     yylval.ival = 0;
3969                 OPERATOR(DOTDOT);
3970             }
3971             if (PL_expect != XOPERATOR)
3972                 check_uni();
3973             Aop(OP_CONCAT);
3974         }
3975         /* FALL THROUGH */
3976     case '0': case '1': case '2': case '3': case '4':
3977     case '5': case '6': case '7': case '8': case '9':
3978         s = scan_num(s, &yylval);
3979         DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
3980         if (PL_expect == XOPERATOR)
3981             no_op("Number",s);
3982         TERM(THING);
3983
3984     case '\'':
3985         s = scan_str(s,FALSE,FALSE);
3986         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
3987         if (PL_expect == XOPERATOR) {
3988             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3989                 PL_expect = XTERM;
3990                 deprecate_old(commaless_variable_list);
3991                 return REPORT(','); /* grandfather non-comma-format format */
3992             }
3993             else
3994                 no_op("String",s);
3995         }
3996         if (!s)
3997             missingterm((char*)0);
3998         yylval.ival = OP_CONST;
3999         TERM(sublex_start());
4000
4001     case '"':
4002         s = scan_str(s,FALSE,FALSE);
4003         DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
4004         if (PL_expect == XOPERATOR) {
4005             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4006                 PL_expect = XTERM;
4007                 deprecate_old(commaless_variable_list);
4008                 return REPORT(','); /* grandfather non-comma-format format */
4009             }
4010             else
4011                 no_op("String",s);
4012         }
4013         if (!s)
4014             missingterm((char*)0);
4015         yylval.ival = OP_CONST;
4016         /* FIXME. I think that this can be const if char *d is replaced by
4017            more localised variables.  */
4018         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4019             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4020                 yylval.ival = OP_STRINGIFY;
4021                 break;
4022             }
4023         }
4024         TERM(sublex_start());
4025
4026     case '`':
4027         s = scan_str(s,FALSE,FALSE);
4028         DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
4029         if (PL_expect == XOPERATOR)
4030             no_op("Backticks",s);
4031         if (!s)
4032             missingterm((char*)0);
4033         yylval.ival = OP_BACKTICK;
4034         set_csh();
4035         TERM(sublex_start());
4036
4037     case '\\':
4038         s++;
4039         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4040             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4041                         *s, *s);
4042         if (PL_expect == XOPERATOR)
4043             no_op("Backslash",s);
4044         OPERATOR(REFGEN);
4045
4046     case 'v':
4047         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4048             char *start = s + 2;
4049             while (isDIGIT(*start) || *start == '_')
4050                 start++;
4051             if (*start == '.' && isDIGIT(start[1])) {
4052                 s = scan_num(s, &yylval);
4053                 TERM(THING);
4054             }
4055             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4056             else if (!isALPHA(*start) && (PL_expect == XTERM
4057                         || PL_expect == XREF || PL_expect == XSTATE
4058                         || PL_expect == XTERMORDORDOR)) {
4059                 const char c = *start;
4060                 GV *gv;
4061                 *start = '\0';
4062                 gv = gv_fetchpv(s, 0, SVt_PVCV);
4063                 *start = c;
4064                 if (!gv) {
4065                     s = scan_num(s, &yylval);
4066                     TERM(THING);
4067                 }
4068             }
4069         }
4070         goto keylookup;
4071     case 'x':
4072         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4073             s++;
4074             Mop(OP_REPEAT);
4075         }
4076         goto keylookup;
4077
4078     case '_':
4079     case 'a': case 'A':
4080     case 'b': case 'B':
4081     case 'c': case 'C':
4082     case 'd': case 'D':
4083     case 'e': case 'E':
4084     case 'f': case 'F':
4085     case 'g': case 'G':
4086     case 'h': case 'H':
4087     case 'i': case 'I':
4088     case 'j': case 'J':
4089     case 'k': case 'K':
4090     case 'l': case 'L':
4091     case 'm': case 'M':
4092     case 'n': case 'N':
4093     case 'o': case 'O':
4094     case 'p': case 'P':
4095     case 'q': case 'Q':
4096     case 'r': case 'R':
4097     case 's': case 'S':
4098     case 't': case 'T':
4099     case 'u': case 'U':
4100               case 'V':
4101     case 'w': case 'W':
4102               case 'X':
4103     case 'y': case 'Y':
4104     case 'z': case 'Z':
4105
4106       keylookup: {
4107         I32 tmp;
4108         I32 orig_keyword = 0;
4109         GV *gv = NULL;
4110         GV **gvp = NULL;
4111
4112         PL_bufptr = s;
4113         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4114
4115         /* Some keywords can be followed by any delimiter, including ':' */
4116         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4117                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4118                              (PL_tokenbuf[0] == 'q' &&
4119                               strchr("qwxr", PL_tokenbuf[1])))));
4120
4121         /* x::* is just a word, unless x is "CORE" */
4122         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4123             goto just_a_word;
4124
4125         d = s;
4126         while (d < PL_bufend && isSPACE(*d))
4127                 d++;    /* no comments skipped here, or s### is misparsed */
4128
4129         /* Is this a label? */
4130         if (!tmp && PL_expect == XSTATE
4131               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4132             s = d + 1;
4133             yylval.pval = savepv(PL_tokenbuf);
4134             CLINE;
4135             TOKEN(LABEL);
4136         }
4137
4138         /* Check for keywords */
4139         tmp = keyword(PL_tokenbuf, len);
4140
4141         /* Is this a word before a => operator? */
4142         if (*d == '=' && d[1] == '>') {
4143             CLINE;
4144             yylval.opval
4145                 = (OP*)newSVOP(OP_CONST, 0,
4146                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4147             yylval.opval->op_private = OPpCONST_BARE;
4148             TERM(WORD);
4149         }
4150
4151         if (tmp < 0) {                  /* second-class keyword? */
4152             GV *ogv = NULL;     /* override (winner) */
4153             GV *hgv = NULL;     /* hidden (loser) */
4154             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4155                 CV *cv;
4156                 if ((gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV)) &&
4157                     (cv = GvCVu(gv)))
4158                 {
4159                     if (GvIMPORTED_CV(gv))
4160                         ogv = gv;
4161                     else if (! CvMETHOD(cv))
4162                         hgv = gv;
4163                 }
4164                 if (!ogv &&
4165                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4166                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4167                     GvCVu(gv) && GvIMPORTED_CV(gv))
4168                 {
4169                     ogv = gv;
4170                 }
4171             }
4172             if (ogv) {
4173                 orig_keyword = tmp;
4174                 tmp = 0;                /* overridden by import or by GLOBAL */
4175             }
4176             else if (gv && !gvp
4177                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4178                      && GvCVu(gv)
4179                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4180             {
4181                 tmp = 0;                /* any sub overrides "weak" keyword */
4182             }
4183             else {                      /* no override */
4184                 tmp = -tmp;
4185                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4186                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4187                             "dump() better written as CORE::dump()");
4188                 }
4189                 gv = Nullgv;
4190                 gvp = 0;
4191                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4192                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4193                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4194                         "Ambiguous call resolved as CORE::%s(), %s",
4195                          GvENAME(hgv), "qualify as such or use &");
4196             }
4197         }
4198
4199       reserved_word:
4200         switch (tmp) {
4201
4202         default:                        /* not a keyword */
4203             /* Trade off - by using this evil construction we can pull the
4204                variable gv into the block labelled keylookup. If not, then
4205                we have to give it function scope so that the goto from the
4206                earlier ':' case doesn't bypass the initialisation.  */
4207             if (0) {
4208             just_a_word_zero_gv:
4209                 gv = NULL;
4210                 gvp = NULL;
4211             }
4212           just_a_word: {
4213                 SV *sv;
4214                 int pkgname = 0;
4215                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4216                 CV *cv;
4217
4218                 /* Get the rest if it looks like a package qualifier */
4219
4220                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4221                     STRLEN morelen;
4222                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4223                                   TRUE, &morelen);
4224                     if (!morelen)
4225                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4226                                 *s == '\'' ? "'" : "::");
4227                     len += morelen;
4228                     pkgname = 1;
4229                 }
4230
4231                 if (PL_expect == XOPERATOR) {
4232                     if (PL_bufptr == PL_linestart) {
4233                         CopLINE_dec(PL_curcop);
4234                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4235                         CopLINE_inc(PL_curcop);
4236                     }
4237                     else
4238                         no_op("Bareword",s);
4239                 }
4240
4241                 /* Look for a subroutine with this name in current package,
4242                    unless name is "Foo::", in which case Foo is a bearword
4243                    (and a package name). */
4244
4245                 if (len > 2 &&
4246                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4247                 {
4248                     if (ckWARN(WARN_BAREWORD)
4249                         && ! gv_fetchpv(PL_tokenbuf, 0, SVt_PVHV))
4250                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4251                             "Bareword \"%s\" refers to nonexistent package",
4252                              PL_tokenbuf);
4253                     len -= 2;
4254                     PL_tokenbuf[len] = '\0';
4255                     gv = Nullgv;
4256                     gvp = 0;
4257                 }
4258                 else {
4259                     len = 0;
4260                     if (!gv) {
4261                         /* Mustn't actually add anything to a symbol table.
4262                            But also don't want to "initialise" any placeholder
4263                            constants that might already be there into full
4264                            blown PVGVs with attached PVCV.  */
4265                         gv = gv_fetchpv(PL_tokenbuf, GV_NOADD_NOINIT,
4266                                         SVt_PVCV);
4267                     }
4268                 }
4269
4270                 /* if we saw a global override before, get the right name */
4271
4272                 if (gvp) {
4273                     sv = newSVpvs("CORE::GLOBAL::");
4274                     sv_catpv(sv,PL_tokenbuf);
4275                 }
4276                 else {
4277                     /* If len is 0, newSVpv does strlen(), which is correct.
4278                        If len is non-zero, then it will be the true length,
4279                        and so the scalar will be created correctly.  */
4280                     sv = newSVpv(PL_tokenbuf,len);
4281                 }
4282
4283                 /* Presume this is going to be a bareword of some sort. */
4284
4285                 CLINE;
4286                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4287                 yylval.opval->op_private = OPpCONST_BARE;
4288                 /* UTF-8 package name? */
4289                 if (UTF && !IN_BYTES &&
4290                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4291                     SvUTF8_on(sv);
4292
4293                 /* And if "Foo::", then that's what it certainly is. */
4294
4295                 if (len)
4296                     goto safe_bareword;
4297
4298                 /* Do the explicit type check so that we don't need to force
4299                    the initialisation of the symbol table to have a real GV.
4300                    Beware - gv may not really be a PVGV, cv may not really be
4301                    a PVCV, (because of the space optimisations that gv_init
4302                    understands) But they're true if for this symbol there is
4303                    respectively a typeglob and a subroutine.
4304                 */
4305                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
4306                     /* Real typeglob, so get the real subroutine: */
4307                            ? GvCVu(gv)
4308                     /* A proxy for a subroutine in this package? */
4309                            : SvOK(gv) ? (CV *) gv : NULL)
4310                     : NULL;
4311
4312                 /* See if it's the indirect object for a list operator. */
4313
4314                 if (PL_oldoldbufptr &&
4315                     PL_oldoldbufptr < PL_bufptr &&
4316                     (PL_oldoldbufptr == PL_last_lop
4317                      || PL_oldoldbufptr == PL_last_uni) &&
4318                     /* NO SKIPSPACE BEFORE HERE! */
4319                     (PL_expect == XREF ||
4320                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4321                 {
4322                     bool immediate_paren = *s == '(';
4323
4324                     /* (Now we can afford to cross potential line boundary.) */
4325                     s = skipspace(s);
4326
4327                     /* Two barewords in a row may indicate method call. */
4328
4329                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
4330                         (tmp = intuit_method(s, gv, cv)))
4331                         return REPORT(tmp);
4332
4333                     /* If not a declared subroutine, it's an indirect object. */
4334                     /* (But it's an indir obj regardless for sort.) */
4335                     /* Also, if "_" follows a filetest operator, it's a bareword */
4336
4337                     if (
4338                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4339                          ((!gv || !cv) &&
4340                         (PL_last_lop_op != OP_MAPSTART &&
4341                          PL_last_lop_op != OP_GREPSTART))))
4342                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
4343                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
4344                        )
4345                     {
4346                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4347                         goto bareword;
4348                     }
4349                 }
4350
4351                 PL_expect = XOPERATOR;
4352                 s = skipspace(s);
4353
4354                 /* Is this a word before a => operator? */
4355                 if (*s == '=' && s[1] == '>' && !pkgname) {
4356                     CLINE;
4357                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4358                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4359                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4360                     TERM(WORD);
4361                 }
4362
4363                 /* If followed by a paren, it's certainly a subroutine. */
4364                 if (*s == '(') {
4365                     CLINE;
4366                     if (cv) {
4367                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4368                         if (*d == ')' && (sv = gv_const_sv(gv))) {
4369                             s = d + 1;
4370                             goto its_constant;
4371                         }
4372                     }
4373                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4374                     PL_expect = XOPERATOR;
4375                     force_next(WORD);
4376                     yylval.ival = 0;
4377                     TOKEN('&');
4378                 }
4379
4380                 /* If followed by var or block, call it a method (unless sub) */
4381
4382                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
4383                     PL_last_lop = PL_oldbufptr;
4384                     PL_last_lop_op = OP_METHOD;
4385                     PREBLOCK(METHOD);
4386                 }
4387
4388                 /* If followed by a bareword, see if it looks like indir obj. */
4389
4390                 if (!orig_keyword
4391                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4392                         && (tmp = intuit_method(s, gv, cv)))
4393                     return REPORT(tmp);
4394
4395                 /* Not a method, so call it a subroutine (if defined) */
4396
4397                 if (cv) {
4398                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4399                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4400                                 "Ambiguous use of -%s resolved as -&%s()",
4401                                 PL_tokenbuf, PL_tokenbuf);
4402                     /* Check for a constant sub */
4403                     if ((sv = gv_const_sv(gv))) {
4404                   its_constant:
4405                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4406                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4407                         yylval.opval->op_private = 0;
4408                         TOKEN(WORD);
4409                     }
4410
4411                     /* Resolve to GV now. */
4412                     if (SvTYPE(gv) != SVt_PVGV) {
4413                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
4414                         assert (SvTYPE(gv) == SVt_PVGV);
4415                         /* cv must have been some sort of placeholder, so
4416                            now needs replacing with a real code reference.  */
4417                         cv = GvCV(gv);
4418                     }
4419
4420                     op_free(yylval.opval);
4421                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4422                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4423                     PL_last_lop = PL_oldbufptr;
4424                     PL_last_lop_op = OP_ENTERSUB;
4425                     /* Is there a prototype? */
4426                     if (SvPOK(cv)) {
4427                         STRLEN len;
4428                         const char *proto = SvPV_const((SV*)cv, len);
4429                         if (!len)
4430                             TERM(FUNC0SUB);
4431                         if (*proto == '$' && proto[1] == '\0')
4432                             OPERATOR(UNIOPSUB);
4433                         while (*proto == ';')
4434                             proto++;
4435                         if (*proto == '&' && *s == '{') {
4436                             sv_setpv(PL_subname, PL_curstash ?
4437                                         "__ANON__" : "__ANON__::__ANON__");
4438                             PREBLOCK(LSTOPSUB);
4439                         }
4440                     }
4441                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4442                     PL_expect = XTERM;
4443                     force_next(WORD);
4444                     TOKEN(NOAMP);
4445                 }
4446
4447                 /* Call it a bare word */
4448
4449                 if (PL_hints & HINT_STRICT_SUBS)
4450                     yylval.opval->op_private |= OPpCONST_STRICT;
4451                 else {
4452                 bareword:
4453                     if (lastchar != '-') {
4454                         if (ckWARN(WARN_RESERVED)) {
4455                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4456                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4457                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4458                                        PL_tokenbuf);
4459                         }
4460                     }
4461                 }
4462
4463             safe_bareword:
4464                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4465                     && ckWARN_d(WARN_AMBIGUOUS)) {
4466                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4467                         "Operator or semicolon missing before %c%s",
4468                         lastchar, PL_tokenbuf);
4469                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4470                         "Ambiguous use of %c resolved as operator %c",
4471                         lastchar, lastchar);
4472                 }
4473                 TOKEN(WORD);
4474             }
4475
4476         case KEY___FILE__:
4477             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4478                                         newSVpv(CopFILE(PL_curcop),0));
4479             TERM(THING);
4480
4481         case KEY___LINE__:
4482             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4483                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4484             TERM(THING);
4485
4486         case KEY___PACKAGE__:
4487             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4488                                         (PL_curstash
4489                                          ? newSVhek(HvNAME_HEK(PL_curstash))
4490                                          : &PL_sv_undef));
4491             TERM(THING);
4492
4493         case KEY___DATA__:
4494         case KEY___END__: {
4495             GV *gv;
4496             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4497                 const char *pname = "main";
4498                 if (PL_tokenbuf[2] == 'D')
4499                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4500                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
4501                                 SVt_PVIO);
4502                 GvMULTI_on(gv);
4503                 if (!GvIO(gv))
4504                     GvIOp(gv) = newIO();
4505                 IoIFP(GvIOp(gv)) = PL_rsfp;
4506 #if defined(HAS_FCNTL) && defined(F_SETFD)
4507                 {
4508                     const int fd = PerlIO_fileno(PL_rsfp);
4509                     fcntl(fd,F_SETFD,fd >= 3);
4510                 }
4511 #endif
4512                 /* Mark this internal pseudo-handle as clean */
4513                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4514                 if (PL_preprocess)
4515                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4516                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4517                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4518                 else
4519                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4520 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4521                 /* if the script was opened in binmode, we need to revert
4522                  * it to text mode for compatibility; but only iff it has CRs
4523                  * XXX this is a questionable hack at best. */
4524                 if (PL_bufend-PL_bufptr > 2
4525                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4526                 {
4527                     Off_t loc = 0;
4528                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4529                         loc = PerlIO_tell(PL_rsfp);
4530                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4531                     }
4532 #ifdef NETWARE
4533                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4534 #else
4535                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4536 #endif  /* NETWARE */
4537 #ifdef PERLIO_IS_STDIO /* really? */
4538 #  if defined(__BORLANDC__)
4539                         /* XXX see note in do_binmode() */
4540                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4541 #  endif
4542 #endif
4543                         if (loc > 0)
4544                             PerlIO_seek(PL_rsfp, loc, 0);
4545                     }
4546                 }
4547 #endif
4548 #ifdef PERLIO_LAYERS
4549                 if (!IN_BYTES) {
4550                     if (UTF)
4551                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4552                     else if (PL_encoding) {
4553                         SV *name;
4554                         dSP;
4555                         ENTER;
4556                         SAVETMPS;
4557                         PUSHMARK(sp);
4558                         EXTEND(SP, 1);
4559                         XPUSHs(PL_encoding);
4560                         PUTBACK;
4561                         call_method("name", G_SCALAR);
4562                         SPAGAIN;
4563                         name = POPs;
4564                         PUTBACK;
4565                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4566                                             Perl_form(aTHX_ ":encoding(%"SVf")",
4567                                                       name));
4568                         FREETMPS;
4569                         LEAVE;
4570                     }
4571                 }
4572 #endif
4573                 PL_rsfp = Nullfp;
4574             }
4575             goto fake_eof;
4576         }
4577
4578         case KEY_AUTOLOAD:
4579         case KEY_DESTROY:
4580         case KEY_BEGIN:
4581         case KEY_CHECK:
4582         case KEY_INIT:
4583         case KEY_END:
4584             if (PL_expect == XSTATE) {
4585                 s = PL_bufptr;
4586                 goto really_sub;
4587             }
4588             goto just_a_word;
4589
4590         case KEY_CORE:
4591             if (*s == ':' && s[1] == ':') {
4592                 s += 2;
4593                 d = s;
4594                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4595                 if (!(tmp = keyword(PL_tokenbuf, len)))
4596                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4597                 if (tmp < 0)
4598                     tmp = -tmp;
4599                 else if (tmp == KEY_require || tmp == KEY_do)
4600                     /* that's a way to remember we saw "CORE::" */
4601                     orig_keyword = tmp;
4602                 goto reserved_word;
4603             }
4604             goto just_a_word;
4605
4606         case KEY_abs:
4607             UNI(OP_ABS);
4608
4609         case KEY_alarm:
4610             UNI(OP_ALARM);
4611
4612         case KEY_accept:
4613             LOP(OP_ACCEPT,XTERM);
4614
4615         case KEY_and:
4616             OPERATOR(ANDOP);
4617
4618         case KEY_atan2:
4619             LOP(OP_ATAN2,XTERM);
4620
4621         case KEY_bind:
4622             LOP(OP_BIND,XTERM);
4623
4624         case KEY_binmode:
4625             LOP(OP_BINMODE,XTERM);
4626
4627         case KEY_bless:
4628             LOP(OP_BLESS,XTERM);
4629
4630         case KEY_break:
4631             FUN0(OP_BREAK);
4632
4633         case KEY_chop:
4634             UNI(OP_CHOP);
4635
4636         case KEY_continue:
4637             /* When 'use switch' is in effect, continue has a dual
4638                life as a control operator. */
4639             {
4640                 if (!FEATURE_IS_ENABLED("switch"))
4641                     PREBLOCK(CONTINUE);
4642                 else {
4643                     /* We have to disambiguate the two senses of
4644                       "continue". If the next token is a '{' then
4645                       treat it as the start of a continue block;
4646                       otherwise treat it as a control operator.
4647                      */
4648                     s = skipspace(s);
4649                     if (*s == '{')
4650             PREBLOCK(CONTINUE);
4651                     else
4652                         FUN0(OP_CONTINUE);
4653                 }
4654             }
4655
4656         case KEY_chdir:
4657             (void)gv_fetchpv("ENV", GV_ADD, SVt_PVHV);  /* may use HOME */
4658             UNI(OP_CHDIR);
4659
4660         case KEY_close:
4661             UNI(OP_CLOSE);
4662
4663         case KEY_closedir:
4664             UNI(OP_CLOSEDIR);
4665
4666         case KEY_cmp:
4667             Eop(OP_SCMP);
4668
4669         case KEY_caller:
4670             UNI(OP_CALLER);
4671
4672         case KEY_crypt:
4673 #ifdef FCRYPT
4674             if (!PL_cryptseen) {
4675                 PL_cryptseen = TRUE;
4676                 init_des();
4677             }
4678 #endif
4679             LOP(OP_CRYPT,XTERM);
4680
4681         case KEY_chmod:
4682             LOP(OP_CHMOD,XTERM);
4683
4684         case KEY_chown:
4685             LOP(OP_CHOWN,XTERM);
4686
4687         case KEY_connect:
4688             LOP(OP_CONNECT,XTERM);
4689
4690         case KEY_chr:
4691             UNI(OP_CHR);
4692
4693         case KEY_cos:
4694             UNI(OP_COS);
4695
4696         case KEY_chroot:
4697             UNI(OP_CHROOT);
4698
4699         case KEY_default:
4700             PREBLOCK(DEFAULT);
4701
4702         case KEY_do:
4703             s = skipspace(s);
4704             if (*s == '{')
4705                 PRETERMBLOCK(DO);
4706             if (*s != '\'')
4707                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4708             if (orig_keyword == KEY_do) {
4709                 orig_keyword = 0;
4710                 yylval.ival = 1;
4711             }
4712             else
4713                 yylval.ival = 0;
4714             OPERATOR(DO);
4715
4716         case KEY_die:
4717             PL_hints |= HINT_BLOCK_SCOPE;
4718             LOP(OP_DIE,XTERM);
4719
4720         case KEY_defined:
4721             UNI(OP_DEFINED);
4722
4723         case KEY_delete:
4724             UNI(OP_DELETE);
4725
4726         case KEY_dbmopen:
4727             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4728             LOP(OP_DBMOPEN,XTERM);
4729
4730         case KEY_dbmclose:
4731             UNI(OP_DBMCLOSE);
4732
4733         case KEY_dump:
4734             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4735             LOOPX(OP_DUMP);
4736
4737         case KEY_else:
4738             PREBLOCK(ELSE);
4739
4740         case KEY_elsif:
4741             yylval.ival = CopLINE(PL_curcop);
4742             OPERATOR(ELSIF);
4743
4744         case KEY_eq:
4745             Eop(OP_SEQ);
4746
4747         case KEY_exists:
4748             UNI(OP_EXISTS);
4749
4750         case KEY_exit:
4751             UNI(OP_EXIT);
4752
4753         case KEY_eval:
4754             s = skipspace(s);
4755             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4756             UNIBRACK(OP_ENTEREVAL);
4757
4758         case KEY_eof:
4759             UNI(OP_EOF);
4760
4761         case KEY_err:
4762             OPERATOR(DOROP);
4763
4764         case KEY_exp:
4765             UNI(OP_EXP);
4766
4767         case KEY_each:
4768             UNI(OP_EACH);
4769
4770         case KEY_exec:
4771             set_csh();
4772             LOP(OP_EXEC,XREF);
4773
4774         case KEY_endhostent:
4775             FUN0(OP_EHOSTENT);
4776
4777         case KEY_endnetent:
4778             FUN0(OP_ENETENT);
4779
4780         case KEY_endservent:
4781             FUN0(OP_ESERVENT);
4782
4783         case KEY_endprotoent:
4784             FUN0(OP_EPROTOENT);
4785
4786         case KEY_endpwent:
4787             FUN0(OP_EPWENT);
4788
4789         case KEY_endgrent:
4790             FUN0(OP_EGRENT);
4791
4792         case KEY_for:
4793         case KEY_foreach:
4794             yylval.ival = CopLINE(PL_curcop);
4795             s = skipspace(s);
4796             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4797                 char *p = s;
4798                 if ((PL_bufend - p) >= 3 &&
4799                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4800                     p += 2;
4801                 else if ((PL_bufend - p) >= 4 &&
4802                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4803                     p += 3;
4804                 p = skipspace(p);
4805                 if (isIDFIRST_lazy_if(p,UTF)) {
4806                     p = scan_ident(p, PL_bufend,
4807                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4808                     p = skipspace(p);
4809                 }
4810                 if (*p != '$')
4811                     Perl_croak(aTHX_ "Missing $ on loop variable");
4812             }
4813             OPERATOR(FOR);
4814
4815         case KEY_formline:
4816             LOP(OP_FORMLINE,XTERM);
4817
4818         case KEY_fork:
4819             FUN0(OP_FORK);
4820
4821         case KEY_fcntl:
4822             LOP(OP_FCNTL,XTERM);
4823
4824         case KEY_fileno:
4825             UNI(OP_FILENO);
4826
4827         case KEY_flock:
4828             LOP(OP_FLOCK,XTERM);
4829
4830         case KEY_gt:
4831             Rop(OP_SGT);
4832
4833         case KEY_ge:
4834             Rop(OP_SGE);
4835
4836         case KEY_grep:
4837             LOP(OP_GREPSTART, XREF);
4838
4839         case KEY_goto:
4840             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4841             LOOPX(OP_GOTO);
4842
4843         case KEY_gmtime:
4844             UNI(OP_GMTIME);
4845
4846         case KEY_getc:
4847             UNIDOR(OP_GETC);
4848
4849         case KEY_getppid:
4850             FUN0(OP_GETPPID);
4851
4852         case KEY_getpgrp:
4853             UNI(OP_GETPGRP);
4854
4855         case KEY_getpriority:
4856             LOP(OP_GETPRIORITY,XTERM);
4857
4858         case KEY_getprotobyname:
4859             UNI(OP_GPBYNAME);
4860
4861         case KEY_getprotobynumber:
4862             LOP(OP_GPBYNUMBER,XTERM);
4863
4864         case KEY_getprotoent:
4865             FUN0(OP_GPROTOENT);
4866
4867         case KEY_getpwent:
4868             FUN0(OP_GPWENT);
4869
4870         case KEY_getpwnam:
4871             UNI(OP_GPWNAM);
4872
4873         case KEY_getpwuid:
4874             UNI(OP_GPWUID);
4875
4876         case KEY_getpeername:
4877             UNI(OP_GETPEERNAME);
4878
4879         case KEY_gethostbyname:
4880             UNI(OP_GHBYNAME);
4881
4882         case KEY_gethostbyaddr:
4883             LOP(OP_GHBYADDR,XTERM);
4884
4885         case KEY_gethostent:
4886             FUN0(OP_GHOSTENT);
4887
4888         case KEY_getnetbyname:
4889             UNI(OP_GNBYNAME);
4890
4891         case KEY_getnetbyaddr:
4892             LOP(OP_GNBYADDR,XTERM);
4893
4894         case KEY_getnetent:
4895             FUN0(OP_GNETENT);
4896
4897         case KEY_getservbyname:
4898             LOP(OP_GSBYNAME,XTERM);
4899
4900         case KEY_getservbyport:
4901             LOP(OP_GSBYPORT,XTERM);
4902
4903         case KEY_getservent:
4904             FUN0(OP_GSERVENT);
4905
4906         case KEY_getsockname:
4907             UNI(OP_GETSOCKNAME);
4908
4909         case KEY_getsockopt:
4910             LOP(OP_GSOCKOPT,XTERM);
4911
4912         case KEY_getgrent:
4913             FUN0(OP_GGRENT);
4914
4915         case KEY_getgrnam:
4916             UNI(OP_GGRNAM);
4917
4918         case KEY_getgrgid:
4919             UNI(OP_GGRGID);
4920
4921         case KEY_getlogin:
4922             FUN0(OP_GETLOGIN);
4923
4924         case KEY_given:
4925             yylval.ival = CopLINE(PL_curcop);
4926             OPERATOR(GIVEN);
4927
4928         case KEY_glob:
4929             set_csh();
4930             LOP(OP_GLOB,XTERM);
4931
4932         case KEY_hex:
4933             UNI(OP_HEX);
4934
4935         case KEY_if:
4936             yylval.ival = CopLINE(PL_curcop);
4937             OPERATOR(IF);
4938
4939         case KEY_index:
4940             LOP(OP_INDEX,XTERM);
4941
4942         case KEY_int:
4943             UNI(OP_INT);
4944
4945         case KEY_ioctl:
4946             LOP(OP_IOCTL,XTERM);
4947
4948         case KEY_join:
4949             LOP(OP_JOIN,XTERM);
4950
4951         case KEY_keys:
4952             UNI(OP_KEYS);
4953
4954         case KEY_kill:
4955             LOP(OP_KILL,XTERM);
4956
4957         case KEY_last:
4958             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4959             LOOPX(OP_LAST);
4960
4961         case KEY_lc:
4962             UNI(OP_LC);
4963
4964         case KEY_lcfirst:
4965             UNI(OP_LCFIRST);
4966
4967         case KEY_local:
4968             yylval.ival = 0;
4969             OPERATOR(LOCAL);
4970
4971         case KEY_length:
4972             UNI(OP_LENGTH);
4973
4974         case KEY_lt:
4975             Rop(OP_SLT);
4976
4977         case KEY_le:
4978             Rop(OP_SLE);
4979
4980         case KEY_localtime:
4981             UNI(OP_LOCALTIME);
4982
4983         case KEY_log:
4984             UNI(OP_LOG);
4985
4986         case KEY_link:
4987             LOP(OP_LINK,XTERM);
4988
4989         case KEY_listen:
4990             LOP(OP_LISTEN,XTERM);
4991
4992         case KEY_lock:
4993             UNI(OP_LOCK);
4994
4995         case KEY_lstat:
4996             UNI(OP_LSTAT);
4997
4998         case KEY_m:
4999             s = scan_pat(s,OP_MATCH);
5000             TERM(sublex_start());
5001
5002         case KEY_map:
5003             LOP(OP_MAPSTART, XREF);
5004
5005         case KEY_mkdir:
5006             LOP(OP_MKDIR,XTERM);
5007
5008         case KEY_msgctl:
5009             LOP(OP_MSGCTL,XTERM);
5010
5011         case KEY_msgget:
5012             LOP(OP_MSGGET,XTERM);
5013
5014         case KEY_msgrcv:
5015             LOP(OP_MSGRCV,XTERM);
5016
5017         case KEY_msgsnd:
5018             LOP(OP_MSGSND,XTERM);
5019
5020         case KEY_our:
5021         case KEY_my:
5022             PL_in_my = tmp;
5023             s = skipspace(s);
5024             if (isIDFIRST_lazy_if(s,UTF)) {
5025                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
5026                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
5027                     goto really_sub;
5028                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
5029                 if (!PL_in_my_stash) {
5030                     char tmpbuf[1024];
5031                     PL_bufptr = s;
5032                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
5033                     yyerror(tmpbuf);
5034                 }
5035             }
5036             yylval.ival = 1;
5037             OPERATOR(MY);
5038
5039         case KEY_next:
5040             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5041             LOOPX(OP_NEXT);
5042
5043         case KEY_ne:
5044             Eop(OP_SNE);
5045
5046         case KEY_no:
5047             s = tokenize_use(0, s);
5048             OPERATOR(USE);
5049
5050         case KEY_not:
5051             if (*s == '(' || (s = skipspace(s), *s == '('))
5052                 FUN1(OP_NOT);
5053             else
5054                 OPERATOR(NOTOP);
5055
5056         case KEY_open:
5057             s = skipspace(s);
5058             if (isIDFIRST_lazy_if(s,UTF)) {
5059                 const char *t;
5060                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
5061                 for (t=d; *t && isSPACE(*t); t++) ;
5062                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
5063                     /* [perl #16184] */
5064                     && !(t[0] == '=' && t[1] == '>')
5065                 ) {
5066                     int len = (int)(d-s);
5067                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5068                            "Precedence problem: open %.*s should be open(%.*s)",
5069                             len, s, len, s);
5070                 }
5071             }
5072             LOP(OP_OPEN,XTERM);
5073
5074         case KEY_or:
5075             yylval.ival = OP_OR;
5076             OPERATOR(OROP);
5077
5078         case KEY_ord:
5079             UNI(OP_ORD);
5080
5081         case KEY_oct:
5082             UNI(OP_OCT);
5083
5084         case KEY_opendir:
5085             LOP(OP_OPEN_DIR,XTERM);
5086
5087         case KEY_print:
5088             checkcomma(s,PL_tokenbuf,"filehandle");
5089             LOP(OP_PRINT,XREF);
5090
5091         case KEY_printf:
5092             checkcomma(s,PL_tokenbuf,"filehandle");
5093             LOP(OP_PRTF,XREF);
5094
5095         case KEY_prototype:
5096             UNI(OP_PROTOTYPE);
5097
5098         case KEY_push:
5099             LOP(OP_PUSH,XTERM);
5100
5101         case KEY_pop:
5102             UNIDOR(OP_POP);
5103
5104         case KEY_pos:
5105             UNIDOR(OP_POS);
5106
5107         case KEY_pack:
5108             LOP(OP_PACK,XTERM);
5109
5110         case KEY_package:
5111             s = force_word(s,WORD,FALSE,TRUE,FALSE);
5112             OPERATOR(PACKAGE);
5113
5114         case KEY_pipe:
5115             LOP(OP_PIPE_OP,XTERM);
5116
5117         case KEY_q:
5118             s = scan_str(s,FALSE,FALSE);
5119             if (!s)
5120                 missingterm((char*)0);
5121             yylval.ival = OP_CONST;
5122             TERM(sublex_start());
5123
5124         case KEY_quotemeta:
5125             UNI(OP_QUOTEMETA);
5126
5127         case KEY_qw:
5128             s = scan_str(s,FALSE,FALSE);
5129             if (!s)
5130                 missingterm((char*)0);
5131             PL_expect = XOPERATOR;
5132             force_next(')');
5133             if (SvCUR(PL_lex_stuff)) {
5134                 OP *words = Nullop;
5135                 int warned = 0;
5136                 d = SvPV_force(PL_lex_stuff, len);
5137                 while (len) {
5138                     SV *sv;
5139                     for (; isSPACE(*d) && len; --len, ++d) ;
5140                     if (len) {
5141                         const char *b = d;
5142                         if (!warned && ckWARN(WARN_QW)) {
5143                             for (; !isSPACE(*d) && len; --len, ++d) {
5144                                 if (*d == ',') {
5145                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5146                                         "Possible attempt to separate words with commas");
5147                                     ++warned;
5148                                 }
5149                                 else if (*d == '#') {
5150                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5151                                         "Possible attempt to put comments in qw() list");
5152                                     ++warned;
5153                                 }
5154                             }
5155                         }
5156                         else {
5157                             for (; !isSPACE(*d) && len; --len, ++d) ;
5158                         }
5159                         sv = newSVpvn(b, d-b);
5160                         if (DO_UTF8(PL_lex_stuff))
5161                             SvUTF8_on(sv);
5162                         words = append_elem(OP_LIST, words,
5163                                             newSVOP(OP_CONST, 0, tokeq(sv)));
5164                     }
5165                 }
5166                 if (words) {
5167                     PL_nextval[PL_nexttoke].opval = words;
5168                     force_next(THING);
5169                 }
5170             }
5171             if (PL_lex_stuff) {
5172                 SvREFCNT_dec(PL_lex_stuff);
5173                 PL_lex_stuff = Nullsv;
5174             }
5175             PL_expect = XTERM;
5176             TOKEN('(');
5177
5178         case KEY_qq:
5179             s = scan_str(s,FALSE,FALSE);
5180             if (!s)
5181                 missingterm((char*)0);
5182             yylval.ival = OP_STRINGIFY;
5183             if (SvIVX(PL_lex_stuff) == '\'')
5184                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
5185             TERM(sublex_start());
5186
5187         case KEY_qr:
5188             s = scan_pat(s,OP_QR);
5189             TERM(sublex_start());
5190
5191         case KEY_qx:
5192             s = scan_str(s,FALSE,FALSE);
5193             if (!s)
5194                 missingterm((char*)0);
5195             yylval.ival = OP_BACKTICK;
5196             set_csh();
5197             TERM(sublex_start());
5198
5199         case KEY_return:
5200             OLDLOP(OP_RETURN);
5201
5202         case KEY_require:
5203             s = skipspace(s);
5204             if (isDIGIT(*s)) {
5205                 s = force_version(s, FALSE);
5206             }
5207             else if (*s != 'v' || !isDIGIT(s[1])
5208                     || (s = force_version(s, TRUE), *s == 'v'))
5209             {
5210                 *PL_tokenbuf = '\0';
5211                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5212                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5213                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5214                 else if (*s == '<')
5215                     yyerror("<> should be quotes");
5216             }
5217             if (orig_keyword == KEY_require) {
5218                 orig_keyword = 0;
5219                 yylval.ival = 1;
5220             }
5221             else
5222                 yylval.ival = 0;
5223             PL_expect = XTERM;
5224             PL_bufptr = s;
5225             PL_last_uni = PL_oldbufptr;
5226             PL_last_lop_op = OP_REQUIRE;
5227             s = skipspace(s);
5228             return REPORT( (int)REQUIRE );
5229
5230         case KEY_reset:
5231             UNI(OP_RESET);
5232
5233         case KEY_redo:
5234             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5235             LOOPX(OP_REDO);
5236
5237         case KEY_rename:
5238             LOP(OP_RENAME,XTERM);
5239
5240         case KEY_rand:
5241             UNI(OP_RAND);
5242
5243         case KEY_rmdir:
5244             UNI(OP_RMDIR);
5245
5246         case KEY_rindex:
5247             LOP(OP_RINDEX,XTERM);
5248
5249         case KEY_read:
5250             LOP(OP_READ,XTERM);
5251
5252         case KEY_readdir:
5253             UNI(OP_READDIR);
5254
5255         case KEY_readline:
5256             set_csh();
5257             UNIDOR(OP_READLINE);
5258
5259         case KEY_readpipe:
5260             set_csh();
5261             UNI(OP_BACKTICK);
5262
5263         case KEY_rewinddir:
5264             UNI(OP_REWINDDIR);
5265
5266         case KEY_recv:
5267             LOP(OP_RECV,XTERM);
5268
5269         case KEY_reverse:
5270             LOP(OP_REVERSE,XTERM);
5271
5272         case KEY_readlink:
5273             UNIDOR(OP_READLINK);
5274
5275         case KEY_ref:
5276             UNI(OP_REF);
5277
5278         case KEY_s:
5279             s = scan_subst(s);
5280             if (yylval.opval)
5281                 TERM(sublex_start());
5282             else
5283                 TOKEN(1);       /* force error */
5284
5285         case KEY_say:
5286             checkcomma(s,PL_tokenbuf,"filehandle");
5287             LOP(OP_SAY,XREF);
5288
5289         case KEY_chomp:
5290             UNI(OP_CHOMP);
5291
5292         case KEY_scalar:
5293             UNI(OP_SCALAR);
5294
5295         case KEY_select:
5296             LOP(OP_SELECT,XTERM);
5297
5298         case KEY_seek:
5299             LOP(OP_SEEK,XTERM);
5300
5301         case KEY_semctl:
5302             LOP(OP_SEMCTL,XTERM);
5303
5304         case KEY_semget:
5305             LOP(OP_SEMGET,XTERM);
5306
5307         case KEY_semop:
5308             LOP(OP_SEMOP,XTERM);
5309
5310         case KEY_send:
5311             LOP(OP_SEND,XTERM);
5312
5313         case KEY_setpgrp:
5314             LOP(OP_SETPGRP,XTERM);
5315
5316         case KEY_setpriority:
5317             LOP(OP_SETPRIORITY,XTERM);
5318
5319         case KEY_sethostent:
5320             UNI(OP_SHOSTENT);
5321
5322         case KEY_setnetent:
5323             UNI(OP_SNETENT);
5324
5325         case KEY_setservent:
5326             UNI(OP_SSERVENT);
5327
5328         case KEY_setprotoent:
5329             UNI(OP_SPROTOENT);
5330
5331         case KEY_setpwent:
5332             FUN0(OP_SPWENT);
5333
5334         case KEY_setgrent:
5335             FUN0(OP_SGRENT);
5336
5337         case KEY_seekdir:
5338             LOP(OP_SEEKDIR,XTERM);
5339
5340         case KEY_setsockopt:
5341             LOP(OP_SSOCKOPT,XTERM);
5342
5343         case KEY_shift:
5344             UNIDOR(OP_SHIFT);
5345
5346         case KEY_shmctl:
5347             LOP(OP_SHMCTL,XTERM);
5348
5349         case KEY_shmget:
5350             LOP(OP_SHMGET,XTERM);
5351
5352         case KEY_shmread:
5353             LOP(OP_SHMREAD,XTERM);
5354
5355         case KEY_shmwrite:
5356             LOP(OP_SHMWRITE,XTERM);
5357
5358         case KEY_shutdown:
5359             LOP(OP_SHUTDOWN,XTERM);
5360
5361         case KEY_sin:
5362             UNI(OP_SIN);
5363
5364         case KEY_sleep:
5365             UNI(OP_SLEEP);
5366
5367         case KEY_socket:
5368             LOP(OP_SOCKET,XTERM);
5369
5370         case KEY_socketpair:
5371             LOP(OP_SOCKPAIR,XTERM);
5372
5373         case KEY_sort:
5374             checkcomma(s,PL_tokenbuf,"subroutine name");
5375             s = skipspace(s);
5376             if (*s == ';' || *s == ')')         /* probably a close */
5377                 Perl_croak(aTHX_ "sort is now a reserved word");
5378             PL_expect = XTERM;
5379             s = force_word(s,WORD,TRUE,TRUE,FALSE);
5380             LOP(OP_SORT,XREF);
5381
5382         case KEY_split:
5383             LOP(OP_SPLIT,XTERM);
5384
5385         case KEY_sprintf:
5386             LOP(OP_SPRINTF,XTERM);
5387
5388         case KEY_splice:
5389             LOP(OP_SPLICE,XTERM);
5390
5391         case KEY_sqrt:
5392             UNI(OP_SQRT);
5393
5394         case KEY_srand:
5395             UNI(OP_SRAND);
5396
5397         case KEY_stat:
5398             UNI(OP_STAT);
5399
5400         case KEY_study:
5401             UNI(OP_STUDY);
5402
5403         case KEY_substr:
5404             LOP(OP_SUBSTR,XTERM);
5405
5406         case KEY_format:
5407         case KEY_sub:
5408           really_sub:
5409             {
5410                 char tmpbuf[sizeof PL_tokenbuf];
5411                 SSize_t tboffset = 0;
5412                 expectation attrful;
5413                 bool have_name, have_proto, bad_proto;
5414                 const int key = tmp;
5415
5416                 s = skipspace(s);
5417
5418                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5419                     (*s == ':' && s[1] == ':'))
5420                 {
5421                     PL_expect = XBLOCK;
5422                     attrful = XATTRBLOCK;
5423                     /* remember buffer pos'n for later force_word */
5424                     tboffset = s - PL_oldbufptr;
5425                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5426                     if (strchr(tmpbuf, ':'))
5427                         sv_setpv(PL_subname, tmpbuf);
5428                     else {
5429                         sv_setsv(PL_subname,PL_curstname);
5430                         sv_catpvs(PL_subname,"::");
5431                         sv_catpvn(PL_subname,tmpbuf,len);
5432                     }
5433                     s = skipspace(d);
5434                     have_name = TRUE;
5435                 }
5436                 else {
5437                     if (key == KEY_my)
5438                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5439                     PL_expect = XTERMBLOCK;
5440                     attrful = XATTRTERM;
5441                     sv_setpvn(PL_subname,"?",1);
5442                     have_name = FALSE;
5443                 }
5444
5445                 if (key == KEY_format) {
5446                     if (*s == '=')
5447                         PL_lex_formbrack = PL_lex_brackets + 1;
5448                     if (have_name)
5449                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5450                                           FALSE, TRUE, TRUE);
5451                     OPERATOR(FORMAT);
5452                 }
5453
5454                 /* Look for a prototype */
5455                 if (*s == '(') {
5456                     char *p;
5457
5458                     s = scan_str(s,FALSE,FALSE);
5459                     if (!s)
5460                         Perl_croak(aTHX_ "Prototype not terminated");
5461                     /* strip spaces and check for bad characters */
5462                     d = SvPVX(PL_lex_stuff);
5463                     tmp = 0;
5464                     bad_proto = FALSE;
5465                     for (p = d; *p; ++p) {
5466                         if (!isSPACE(*p)) {
5467                             d[tmp++] = *p;
5468                             if (!strchr("$@%*;[]&\\", *p))
5469                                 bad_proto = TRUE;
5470                         }
5471                     }
5472                     d[tmp] = '\0';
5473                     if (bad_proto && ckWARN(WARN_SYNTAX))
5474                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5475                                     "Illegal character in prototype for %"SVf" : %s",
5476                                     PL_subname, d);
5477                     SvCUR_set(PL_lex_stuff, tmp);
5478                     have_proto = TRUE;
5479
5480                     s = skipspace(s);
5481                 }
5482                 else
5483                     have_proto = FALSE;
5484
5485                 if (*s == ':' && s[1] != ':')
5486                     PL_expect = attrful;
5487                 else if (*s != '{' && key == KEY_sub) {
5488                     if (!have_name)
5489                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5490                     else if (*s != ';')
5491                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5492                 }
5493
5494                 if (have_proto) {
5495                     PL_nextval[PL_nexttoke].opval =
5496                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5497                     PL_lex_stuff = Nullsv;
5498                     force_next(THING);
5499                 }
5500                 if (!have_name) {
5501                     sv_setpv(PL_subname,
5502                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5503                     TOKEN(ANONSUB);
5504                 }
5505                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5506                                   FALSE, TRUE, TRUE);
5507                 if (key == KEY_my)
5508                     TOKEN(MYSUB);
5509                 TOKEN(SUB);
5510             }
5511
5512         case KEY_system:
5513             set_csh();
5514             LOP(OP_SYSTEM,XREF);
5515
5516         case KEY_symlink:
5517             LOP(OP_SYMLINK,XTERM);
5518
5519         case KEY_syscall:
5520             LOP(OP_SYSCALL,XTERM);
5521
5522         case KEY_sysopen:
5523             LOP(OP_SYSOPEN,XTERM);
5524
5525         case KEY_sysseek:
5526             LOP(OP_SYSSEEK,XTERM);
5527
5528         case KEY_sysread:
5529             LOP(OP_SYSREAD,XTERM);
5530
5531         case KEY_syswrite:
5532             LOP(OP_SYSWRITE,XTERM);
5533
5534         case KEY_tr:
5535             s = scan_trans(s);
5536             TERM(sublex_start());
5537
5538         case KEY_tell:
5539             UNI(OP_TELL);
5540
5541         case KEY_telldir:
5542             UNI(OP_TELLDIR);
5543
5544         case KEY_tie:
5545             LOP(OP_TIE,XTERM);
5546
5547         case KEY_tied:
5548             UNI(OP_TIED);
5549
5550         case KEY_time:
5551             FUN0(OP_TIME);
5552
5553         case KEY_times:
5554             FUN0(OP_TMS);
5555
5556         case KEY_truncate:
5557             LOP(OP_TRUNCATE,XTERM);
5558
5559         case KEY_uc:
5560             UNI(OP_UC);
5561
5562         case KEY_ucfirst:
5563             UNI(OP_UCFIRST);
5564
5565         case KEY_untie:
5566             UNI(OP_UNTIE);
5567
5568         case KEY_until:
5569             yylval.ival = CopLINE(PL_curcop);
5570             OPERATOR(UNTIL);
5571
5572         case KEY_unless:
5573             yylval.ival = CopLINE(PL_curcop);
5574             OPERATOR(UNLESS);
5575
5576         case KEY_unlink:
5577             LOP(OP_UNLINK,XTERM);
5578
5579         case KEY_undef:
5580             UNIDOR(OP_UNDEF);
5581
5582         case KEY_unpack:
5583             LOP(OP_UNPACK,XTERM);
5584
5585         case KEY_utime:
5586             LOP(OP_UTIME,XTERM);
5587
5588         case KEY_umask:
5589             UNIDOR(OP_UMASK);
5590
5591         case KEY_unshift:
5592             LOP(OP_UNSHIFT,XTERM);
5593
5594         case KEY_use:
5595             s = tokenize_use(1, s);
5596             OPERATOR(USE);
5597
5598         case KEY_values:
5599             UNI(OP_VALUES);
5600
5601         case KEY_vec:
5602             LOP(OP_VEC,XTERM);
5603
5604         case KEY_when:
5605             yylval.ival = CopLINE(PL_curcop);
5606             OPERATOR(WHEN);
5607
5608         case KEY_while:
5609             yylval.ival = CopLINE(PL_curcop);
5610             OPERATOR(WHILE);
5611
5612         case KEY_warn:
5613             PL_hints |= HINT_BLOCK_SCOPE;
5614             LOP(OP_WARN,XTERM);
5615
5616         case KEY_wait:
5617             FUN0(OP_WAIT);
5618
5619         case KEY_waitpid:
5620             LOP(OP_WAITPID,XTERM);
5621
5622         case KEY_wantarray:
5623             FUN0(OP_WANTARRAY);
5624
5625         case KEY_write:
5626 #ifdef EBCDIC
5627         {
5628             char ctl_l[2];
5629             ctl_l[0] = toCTRL('L');
5630             ctl_l[1] = '\0';
5631             gv_fetchpv(ctl_l, GV_ADD, SVt_PV);
5632         }
5633 #else
5634             gv_fetchpv("\f", GV_ADD, SVt_PV);    /* Make sure $^L is defined */
5635 #endif
5636             UNI(OP_ENTERWRITE);
5637
5638         case KEY_x:
5639             if (PL_expect == XOPERATOR)
5640                 Mop(OP_REPEAT);
5641             check_uni();
5642             goto just_a_word;
5643
5644         case KEY_xor:
5645             yylval.ival = OP_XOR;
5646             OPERATOR(OROP);
5647
5648         case KEY_y:
5649             s = scan_trans(s);
5650             TERM(sublex_start());
5651         }
5652     }}
5653 }
5654 #ifdef __SC__
5655 #pragma segment Main
5656 #endif
5657
5658 static int
5659 S_pending_ident(pTHX)
5660 {
5661     register char *d;
5662     register I32 tmp = 0;
5663     /* pit holds the identifier we read and pending_ident is reset */
5664     char pit = PL_pending_ident;
5665     PL_pending_ident = 0;
5666
5667     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5668           "### Pending identifier '%s'\n", PL_tokenbuf); });
5669
5670     /* if we're in a my(), we can't allow dynamics here.
5671        $foo'bar has already been turned into $foo::bar, so
5672        just check for colons.
5673
5674        if it's a legal name, the OP is a PADANY.
5675     */
5676     if (PL_in_my) {
5677         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5678             if (strchr(PL_tokenbuf,':'))
5679                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5680                                   "variable %s in \"our\"",
5681                                   PL_tokenbuf));
5682             tmp = allocmy(PL_tokenbuf);
5683         }
5684         else {
5685             if (strchr(PL_tokenbuf,':'))
5686                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5687
5688             yylval.opval = newOP(OP_PADANY, 0);
5689             yylval.opval->op_targ = allocmy(PL_tokenbuf);
5690             return PRIVATEREF;
5691         }
5692     }
5693
5694     /*
5695        build the ops for accesses to a my() variable.
5696
5697        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5698        then used in a comparison.  This catches most, but not
5699        all cases.  For instance, it catches
5700            sort { my($a); $a <=> $b }
5701        but not
5702            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5703        (although why you'd do that is anyone's guess).
5704     */
5705
5706     if (!strchr(PL_tokenbuf,':')) {
5707         if (!PL_in_my)
5708             tmp = pad_findmy(PL_tokenbuf);
5709         if (tmp != NOT_IN_PAD) {
5710             /* might be an "our" variable" */
5711             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5712                 /* build ops for a bareword */
5713                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
5714                 HEK * const stashname = HvNAME_HEK(stash);
5715                 SV *  const sym = newSVhek(stashname);
5716                 sv_catpvs(sym, "::");
5717                 sv_catpv(sym, PL_tokenbuf+1);
5718                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5719                 yylval.opval->op_private = OPpCONST_ENTERED;
5720                 gv_fetchsv(sym,
5721                     (PL_in_eval
5722                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5723                         : GV_ADDMULTI
5724                     ),
5725                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5726                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5727                      : SVt_PVHV));
5728                 return WORD;
5729             }
5730
5731             /* if it's a sort block and they're naming $a or $b */
5732             if (PL_last_lop_op == OP_SORT &&
5733                 PL_tokenbuf[0] == '$' &&
5734                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5735                 && !PL_tokenbuf[2])
5736             {
5737                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5738                      d < PL_bufend && *d != '\n';
5739                      d++)
5740                 {
5741                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5742                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5743                               PL_tokenbuf);
5744                     }
5745                 }
5746             }
5747
5748             yylval.opval = newOP(OP_PADANY, 0);
5749             yylval.opval->op_targ = tmp;
5750             return PRIVATEREF;
5751         }
5752     }
5753
5754     /*
5755        Whine if they've said @foo in a doublequoted string,
5756        and @foo isn't a variable we can find in the symbol
5757        table.
5758     */
5759     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5760         GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
5761         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5762              && ckWARN(WARN_AMBIGUOUS))
5763         {
5764             /* Downgraded from fatal to warning 20000522 mjd */
5765             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5766                         "Possible unintended interpolation of %s in string",
5767                          PL_tokenbuf);
5768         }
5769     }
5770
5771     /* build ops for a bareword */
5772     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5773     yylval.opval->op_private = OPpCONST_ENTERED;
5774     gv_fetchpv(
5775             PL_tokenbuf+1,
5776             PL_in_eval
5777                 ? (GV_ADDMULTI | GV_ADDINEVAL)
5778                 /* If the identifier refers to a stash, don't autovivify it.
5779                  * Change 24660 had the side effect of causing symbol table
5780                  * hashes to always be defined, even if they were freshly
5781                  * created and the only reference in the entire program was
5782                  * the single statement with the defined %foo::bar:: test.
5783                  * It appears that all code in the wild doing this actually
5784                  * wants to know whether sub-packages have been loaded, so
5785                  * by avoiding auto-vivifying symbol tables, we ensure that
5786                  * defined %foo::bar:: continues to be false, and the existing
5787                  * tests still give the expected answers, even though what
5788                  * they're actually testing has now changed subtly.
5789                  */
5790                 : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'),
5791             ((PL_tokenbuf[0] == '$') ? SVt_PV
5792              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5793              : SVt_PVHV));
5794     return WORD;
5795 }
5796
5797 /*
5798  *  The following code was generated by perl_keyword.pl.
5799  */
5800
5801 I32
5802 Perl_keyword (pTHX_ const char *name, I32 len)
5803 {
5804   switch (len)
5805   {
5806     case 1: /* 5 tokens of length 1 */
5807       switch (name[0])
5808       {
5809         case 'm':
5810           {                                       /* m          */
5811             return KEY_m;
5812           }
5813
5814         case 'q':
5815           {                                       /* q          */
5816             return KEY_q;
5817           }
5818
5819         case 's':
5820           {                                       /* s          */
5821             return KEY_s;
5822           }
5823
5824         case 'x':
5825           {                                       /* x          */
5826             return -KEY_x;
5827           }
5828
5829         case 'y':
5830           {                                       /* y          */
5831             return KEY_y;
5832           }
5833
5834         default:
5835           goto unknown;
5836       }
5837
5838     case 2: /* 18 tokens of length 2 */
5839       switch (name[0])
5840       {
5841         case 'd':
5842           if (name[1] == 'o')
5843           {                                       /* do         */
5844             return KEY_do;
5845           }
5846
5847           goto unknown;
5848
5849         case 'e':
5850           if (name[1] == 'q')
5851           {                                       /* eq         */
5852             return -KEY_eq;
5853           }
5854
5855           goto unknown;
5856
5857         case 'g':
5858           switch (name[1])
5859           {
5860             case 'e':
5861               {                                   /* ge         */
5862                 return -KEY_ge;
5863               }
5864
5865             case 't':
5866               {                                   /* gt         */
5867                 return -KEY_gt;
5868               }
5869
5870             default:
5871               goto unknown;
5872           }
5873
5874         case 'i':
5875           if (name[1] == 'f')
5876           {                                       /* if         */
5877             return KEY_if;
5878           }
5879
5880           goto unknown;
5881
5882         case 'l':
5883           switch (name[1])
5884           {
5885             case 'c':
5886               {                                   /* lc         */
5887                 return -KEY_lc;
5888               }
5889
5890             case 'e':
5891               {                                   /* le         */
5892                 return -KEY_le;
5893               }
5894
5895             case 't':
5896               {                                   /* lt         */
5897                 return -KEY_lt;
5898               }
5899
5900             default:
5901               goto unknown;
5902           }
5903
5904         case 'm':
5905           if (name[1] == 'y')
5906           {                                       /* my         */
5907             return KEY_my;
5908           }
5909
5910           goto unknown;
5911
5912         case 'n':
5913           switch (name[1])
5914           {
5915             case 'e':
5916               {                                   /* ne         */
5917                 return -KEY_ne;
5918               }
5919
5920             case 'o':
5921               {                                   /* no         */
5922                 return KEY_no;
5923               }
5924
5925             default:
5926               goto unknown;
5927           }
5928
5929         case 'o':
5930           if (name[1] == 'r')
5931           {                                       /* or         */
5932             return -KEY_or;
5933           }
5934
5935           goto unknown;
5936
5937         case 'q':
5938           switch (name[1])
5939           {
5940             case 'q':
5941               {                                   /* qq         */
5942                 return KEY_qq;
5943               }
5944
5945             case 'r':
5946               {                                   /* qr         */
5947                 return KEY_qr;
5948               }
5949
5950             case 'w':
5951               {                                   /* qw         */
5952                 return KEY_qw;
5953               }
5954
5955             case 'x':
5956               {                                   /* qx         */
5957                 return KEY_qx;
5958               }
5959
5960             default:
5961               goto unknown;
5962           }
5963
5964         case 't':
5965           if (name[1] == 'r')
5966           {                                       /* tr         */
5967             return KEY_tr;
5968           }
5969
5970           goto unknown;
5971
5972         case 'u':
5973           if (name[1] == 'c')
5974           {                                       /* uc         */
5975             return -KEY_uc;
5976           }
5977
5978           goto unknown;
5979
5980         default:
5981           goto unknown;
5982       }
5983
5984     case 3: /* 29 tokens of length 3 */
5985       switch (name[0])
5986       {
5987         case 'E':
5988           if (name[1] == 'N' &&
5989               name[2] == 'D')
5990           {                                       /* END        */
5991             return KEY_END;
5992           }
5993
5994           goto unknown;
5995
5996         case 'a':
5997           switch (name[1])
5998           {
5999             case 'b':
6000               if (name[2] == 's')
6001               {                                   /* abs        */
6002                 return -KEY_abs;
6003               }
6004
6005               goto unknown;
6006
6007             case 'n':
6008               if (name[2] == 'd')
6009               {                                   /* and        */
6010                 return -KEY_and;
6011               }
6012
6013               goto unknown;
6014
6015             default:
6016               goto unknown;
6017           }
6018
6019         case 'c':
6020           switch (name[1])
6021           {
6022             case 'h':
6023               if (name[2] == 'r')
6024               {                                   /* chr        */
6025                 return -KEY_chr;
6026               }
6027
6028               goto unknown;
6029
6030             case 'm':
6031               if (name[2] == 'p')
6032               {                                   /* cmp        */
6033                 return -KEY_cmp;
6034               }
6035
6036               goto unknown;
6037
6038             case 'o':
6039               if (name[2] == 's')
6040               {                                   /* cos        */
6041                 return -KEY_cos;
6042               }
6043
6044               goto unknown;
6045
6046             default:
6047               goto unknown;
6048           }
6049
6050         case 'd':
6051           if (name[1] == 'i' &&
6052               name[2] == 'e')
6053           {                                       /* die        */
6054             return -KEY_die;
6055           }
6056
6057           goto unknown;
6058
6059         case 'e':
6060           switch (name[1])
6061           {
6062             case 'o':
6063               if (name[2] == 'f')
6064               {                                   /* eof        */
6065                 return -KEY_eof;
6066               }
6067
6068               goto unknown;
6069
6070             case 'r':
6071               if (name[2] == 'r')
6072               {                                   /* err        */
6073                 return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
6074               }
6075
6076               goto unknown;
6077
6078             case 'x':
6079               if (name[2] == 'p')
6080               {                                   /* exp        */
6081                 return -KEY_exp;
6082               }
6083
6084               goto unknown;
6085
6086             default:
6087               goto unknown;
6088           }
6089
6090         case 'f':
6091           if (name[1] == 'o' &&
6092               name[2] == 'r')
6093           {                                       /* for        */
6094             return KEY_for;
6095           }
6096
6097           goto unknown;
6098
6099         case 'h':
6100           if (name[1] == 'e' &&
6101               name[2] == 'x')
6102           {                                       /* hex        */
6103             return -KEY_hex;
6104           }
6105
6106           goto unknown;
6107
6108         case 'i':
6109           if (name[1] == 'n' &&
6110               name[2] == 't')
6111           {                                       /* int        */
6112             return -KEY_int;
6113           }
6114
6115           goto unknown;
6116
6117         case 'l':
6118           if (name[1] == 'o' &&
6119               name[2] == 'g')
6120           {                                       /* log        */
6121             return -KEY_log;
6122           }
6123
6124           goto unknown;
6125
6126         case 'm':
6127           if (name[1] == 'a' &&
6128               name[2] == 'p')
6129           {                                       /* map        */
6130             return KEY_map;
6131           }
6132
6133           goto unknown;
6134
6135         case 'n':
6136           if (name[1] == 'o' &&
6137               name[2] == 't')
6138           {                                       /* not        */
6139             return -KEY_not;
6140           }
6141
6142           goto unknown;
6143
6144         case 'o':
6145           switch (name[1])
6146           {
6147             case 'c':
6148               if (name[2] == 't')
6149               {                                   /* oct        */
6150                 return -KEY_oct;
6151               }
6152
6153               goto unknown;
6154
6155             case 'r':
6156               if (name[2] == 'd')
6157               {                                   /* ord        */
6158                 return -KEY_ord;
6159               }
6160
6161               goto unknown;
6162
6163             case 'u':
6164               if (name[2] == 'r')
6165               {                                   /* our        */
6166                 return KEY_our;
6167               }
6168
6169               goto unknown;
6170
6171             default:
6172               goto unknown;
6173           }
6174
6175         case 'p':
6176           if (name[1] == 'o')
6177           {
6178             switch (name[2])
6179             {
6180               case 'p':
6181                 {                                 /* pop        */
6182                   return -KEY_pop;
6183                 }
6184
6185               case 's':
6186                 {                                 /* pos        */
6187                   return KEY_pos;
6188                 }
6189
6190               default:
6191                 goto unknown;
6192             }
6193           }
6194
6195           goto unknown;
6196
6197         case 'r':
6198           if (name[1] == 'e' &&
6199               name[2] == 'f')
6200           {                                       /* ref        */
6201             return -KEY_ref;
6202           }
6203
6204           goto unknown;
6205
6206         case 's':
6207           switch (name[1])
6208           {
6209             case 'a':
6210               if (name[2] == 'y')
6211               {                                   /* say        */
6212                 return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
6213               }
6214
6215               goto unknown;
6216
6217             case 'i':
6218               if (name[2] == 'n')
6219               {                                   /* sin        */
6220                 return -KEY_sin;
6221               }
6222
6223               goto unknown;
6224
6225             case 'u':
6226               if (name[2] == 'b')
6227               {                                   /* sub        */
6228                 return KEY_sub;
6229               }
6230
6231               goto unknown;
6232
6233             default:
6234               goto unknown;
6235           }
6236
6237         case 't':
6238           if (name[1] == 'i' &&
6239               name[2] == 'e')
6240           {                                       /* tie        */
6241             return KEY_tie;
6242           }
6243
6244           goto unknown;
6245
6246         case 'u':
6247           if (name[1] == 's' &&
6248               name[2] == 'e')
6249           {                                       /* use        */
6250             return KEY_use;
6251           }
6252
6253           goto unknown;
6254
6255         case 'v':
6256           if (name[1] == 'e' &&
6257               name[2] == 'c')
6258           {                                       /* vec        */
6259             return -KEY_vec;
6260           }
6261
6262           goto unknown;
6263
6264         case 'x':
6265           if (name[1] == 'o' &&
6266               name[2] == 'r')
6267           {                                       /* xor        */
6268             return -KEY_xor;
6269           }
6270
6271           goto unknown;
6272
6273         default:
6274           goto unknown;
6275       }
6276
6277     case 4: /* 41 tokens of length 4 */
6278       switch (name[0])
6279       {
6280         case 'C':
6281           if (name[1] == 'O' &&
6282               name[2] == 'R' &&
6283               name[3] == 'E')
6284           {                                       /* CORE       */
6285             return -KEY_CORE;
6286           }
6287
6288           goto unknown;
6289
6290         case 'I':
6291           if (name[1] == 'N' &&
6292               name[2] == 'I' &&
6293               name[3] == 'T')
6294           {                                       /* INIT       */
6295             return KEY_INIT;
6296           }
6297
6298           goto unknown;
6299
6300         case 'b':
6301           if (name[1] == 'i' &&
6302               name[2] == 'n' &&
6303               name[3] == 'd')
6304           {                                       /* bind       */
6305             return -KEY_bind;
6306           }
6307
6308           goto unknown;
6309
6310         case 'c':
6311           if (name[1] == 'h' &&
6312               name[2] == 'o' &&
6313               name[3] == 'p')
6314           {                                       /* chop       */
6315             return -KEY_chop;
6316           }
6317
6318           goto unknown;
6319
6320         case 'd':
6321           if (name[1] == 'u' &&
6322               name[2] == 'm' &&
6323               name[3] == 'p')
6324           {                                       /* dump       */
6325             return -KEY_dump;
6326           }
6327
6328           goto unknown;
6329
6330         case 'e':
6331           switch (name[1])
6332           {
6333             case 'a':
6334               if (name[2] == 'c' &&
6335                   name[3] == 'h')
6336               {                                   /* each       */
6337                 return -KEY_each;
6338               }
6339
6340               goto unknown;
6341
6342             case 'l':
6343               if (name[2] == 's' &&
6344                   name[3] == 'e')
6345               {                                   /* else       */
6346                 return KEY_else;
6347               }
6348
6349               goto unknown;
6350
6351             case 'v':
6352               if (name[2] == 'a' &&
6353                   name[3] == 'l')
6354               {                                   /* eval       */
6355                 return KEY_eval;
6356               }
6357
6358               goto unknown;
6359
6360             case 'x':
6361               switch (name[2])
6362               {
6363                 case 'e':
6364                   if (name[3] == 'c')
6365                   {                               /* exec       */
6366                     return -KEY_exec;
6367                   }
6368
6369                   goto unknown;
6370
6371                 case 'i':
6372                   if (name[3] == 't')
6373                   {                               /* exit       */
6374                     return -KEY_exit;
6375                   }
6376
6377                   goto unknown;
6378
6379                 default:
6380                   goto unknown;
6381               }
6382
6383             default:
6384               goto unknown;
6385           }
6386
6387         case 'f':
6388           if (name[1] == 'o' &&
6389               name[2] == 'r' &&
6390               name[3] == 'k')
6391           {                                       /* fork       */
6392             return -KEY_fork;
6393           }
6394
6395           goto unknown;
6396
6397         case 'g':
6398           switch (name[1])
6399           {
6400             case 'e':
6401               if (name[2] == 't' &&
6402                   name[3] == 'c')
6403               {                                   /* getc       */
6404                 return -KEY_getc;
6405               }
6406
6407               goto unknown;
6408
6409             case 'l':
6410               if (name[2] == 'o' &&
6411                   name[3] == 'b')
6412               {                                   /* glob       */
6413                 return KEY_glob;
6414               }
6415
6416               goto unknown;
6417
6418             case 'o':
6419               if (name[2] == 't' &&
6420                   name[3] == 'o')
6421               {                                   /* goto       */
6422                 return KEY_goto;
6423               }
6424
6425               goto unknown;
6426
6427             case 'r':
6428               if (name[2] == 'e' &&
6429                   name[3] == 'p')
6430               {                                   /* grep       */
6431                 return KEY_grep;
6432               }
6433
6434               goto unknown;
6435
6436             default:
6437               goto unknown;
6438           }
6439
6440         case 'j':
6441           if (name[1] == 'o' &&
6442               name[2] == 'i' &&
6443               name[3] == 'n')
6444           {                                       /* join       */
6445             return -KEY_join;
6446           }
6447
6448           goto unknown;
6449
6450         case 'k':
6451           switch (name[1])
6452           {
6453             case 'e':
6454               if (name[2] == 'y' &&
6455                   name[3] == 's')
6456               {                                   /* keys       */
6457                 return -KEY_keys;
6458               }
6459
6460               goto unknown;
6461
6462             case 'i':
6463               if (name[2] == 'l' &&
6464                   name[3] == 'l')
6465               {                                   /* kill       */
6466                 return -KEY_kill;
6467               }
6468
6469               goto unknown;
6470
6471             default:
6472               goto unknown;
6473           }
6474
6475         case 'l':
6476           switch (name[1])
6477           {
6478             case 'a':
6479               if (name[2] == 's' &&
6480                   name[3] == 't')
6481               {                                   /* last       */
6482                 return KEY_last;
6483               }
6484
6485               goto unknown;
6486
6487             case 'i':
6488               if (name[2] == 'n' &&
6489                   name[3] == 'k')
6490               {                                   /* link       */
6491                 return -KEY_link;
6492               }
6493
6494               goto unknown;
6495
6496             case 'o':
6497               if (name[2] == 'c' &&
6498                   name[3] == 'k')
6499               {                                   /* lock       */
6500                 return -KEY_lock;
6501               }
6502
6503               goto unknown;
6504
6505             default:
6506               goto unknown;
6507           }
6508
6509         case 'n':
6510           if (name[1] == 'e' &&
6511               name[2] == 'x' &&
6512               name[3] == 't')
6513           {                                       /* next       */
6514             return KEY_next;
6515           }
6516
6517           goto unknown;
6518
6519         case 'o':
6520           if (name[1] == 'p' &&
6521               name[2] == 'e' &&
6522               name[3] == 'n')
6523           {                                       /* open       */
6524             return -KEY_open;
6525           }
6526
6527           goto unknown;
6528
6529         case 'p':
6530           switch (name[1])
6531           {
6532             case 'a':
6533               if (name[2] == 'c' &&
6534                   name[3] == 'k')
6535               {                                   /* pack       */
6536                 return -KEY_pack;
6537               }
6538
6539               goto unknown;
6540
6541             case 'i':
6542               if (name[2] == 'p' &&
6543                   name[3] == 'e')
6544               {                                   /* pipe       */
6545                 return -KEY_pipe;
6546               }
6547
6548               goto unknown;
6549
6550             case 'u':
6551               if (name[2] == 's' &&
6552                   name[3] == 'h')
6553               {                                   /* push       */
6554                 return -KEY_push;
6555               }
6556
6557               goto unknown;
6558
6559             default:
6560               goto unknown;
6561           }
6562
6563         case 'r':
6564           switch (name[1])
6565           {
6566             case 'a':
6567               if (name[2] == 'n' &&
6568                   name[3] == 'd')
6569               {                                   /* rand       */
6570                 return -KEY_rand;
6571               }
6572
6573               goto unknown;
6574
6575             case 'e':
6576               switch (name[2])
6577               {
6578                 case 'a':
6579                   if (name[3] == 'd')
6580                   {                               /* read       */
6581                     return -KEY_read;
6582                   }
6583
6584                   goto unknown;
6585
6586                 case 'c':
6587                   if (name[3] == 'v')
6588                   {                               /* recv       */
6589                     return -KEY_recv;
6590                   }
6591
6592                   goto unknown;
6593
6594                 case 'd':
6595                   if (name[3] == 'o')
6596                   {                               /* redo       */
6597                     return KEY_redo;
6598                   }
6599
6600                   goto unknown;
6601
6602                 default:
6603                   goto unknown;
6604               }
6605
6606             default:
6607               goto unknown;
6608           }
6609
6610         case 's':
6611           switch (name[1])
6612           {
6613             case 'e':
6614               switch (name[2])
6615               {
6616                 case 'e':
6617                   if (name[3] == 'k')
6618                   {                               /* seek       */
6619                     return -KEY_seek;
6620                   }
6621
6622                   goto unknown;
6623
6624                 case 'n':
6625                   if (name[3] == 'd')
6626                   {                               /* send       */
6627                     return -KEY_send;
6628                   }
6629
6630                   goto unknown;
6631
6632                 default:
6633                   goto unknown;
6634               }
6635
6636             case 'o':
6637               if (name[2] == 'r' &&
6638                   name[3] == 't')
6639               {                                   /* sort       */
6640                 return KEY_sort;
6641               }
6642
6643               goto unknown;
6644
6645             case 'q':
6646               if (name[2] == 'r' &&
6647                   name[3] == 't')
6648               {                                   /* sqrt       */
6649                 return -KEY_sqrt;
6650               }
6651
6652               goto unknown;
6653
6654             case 't':
6655               if (name[2] == 'a' &&
6656                   name[3] == 't')
6657               {                                   /* stat       */
6658                 return -KEY_stat;
6659               }
6660
6661               goto unknown;
6662
6663             default:
6664               goto unknown;
6665           }
6666
6667         case 't':
6668           switch (name[1])
6669           {
6670             case 'e':
6671               if (name[2] == 'l' &&
6672                   name[3] == 'l')
6673               {                                   /* tell       */
6674                 return -KEY_tell;
6675               }
6676
6677               goto unknown;
6678
6679             case 'i':
6680               switch (name[2])
6681               {
6682                 case 'e':
6683                   if (name[3] == 'd')
6684                   {                               /* tied       */
6685                     return KEY_tied;
6686                   }
6687
6688                   goto unknown;
6689
6690                 case 'm':
6691                   if (name[3] == 'e')
6692                   {                               /* time       */
6693                     return -KEY_time;
6694                   }
6695
6696                   goto unknown;
6697
6698                 default:
6699                   goto unknown;
6700               }
6701
6702             default:
6703               goto unknown;
6704           }
6705
6706         case 'w':
6707           switch (name[1])
6708           {
6709             case 'a':
6710             switch (name[2])
6711             {
6712               case 'i':
6713                 if (name[3] == 't')
6714                 {                                 /* wait       */
6715                   return -KEY_wait;
6716                 }
6717
6718                 goto unknown;
6719
6720               case 'r':
6721                 if (name[3] == 'n')
6722                 {                                 /* warn       */
6723                   return -KEY_warn;
6724                 }
6725
6726                 goto unknown;
6727
6728               default:
6729                 goto unknown;
6730             }
6731
6732             case 'h':
6733               if (name[2] == 'e' &&
6734                   name[3] == 'n')
6735               {                                   /* when       */
6736                 return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
6737           }
6738
6739           goto unknown;
6740
6741         default:
6742           goto unknown;
6743       }
6744
6745         default:
6746           goto unknown;
6747       }
6748
6749     case 5: /* 38 tokens of length 5 */
6750       switch (name[0])
6751       {
6752         case 'B':
6753           if (name[1] == 'E' &&
6754               name[2] == 'G' &&
6755               name[3] == 'I' &&
6756               name[4] == 'N')
6757           {                                       /* BEGIN      */
6758             return KEY_BEGIN;
6759           }
6760
6761           goto unknown;
6762
6763         case 'C':
6764           if (name[1] == 'H' &&
6765               name[2] == 'E' &&
6766               name[3] == 'C' &&
6767               name[4] == 'K')
6768           {                                       /* CHECK      */
6769             return KEY_CHECK;
6770           }
6771
6772           goto unknown;
6773
6774         case 'a':
6775           switch (name[1])
6776           {
6777             case 'l':
6778               if (name[2] == 'a' &&
6779                   name[3] == 'r' &&
6780                   name[4] == 'm')
6781               {                                   /* alarm      */
6782                 return -KEY_alarm;
6783               }
6784
6785               goto unknown;
6786
6787             case 't':
6788               if (name[2] == 'a' &&
6789                   name[3] == 'n' &&
6790                   name[4] == '2')
6791               {                                   /* atan2      */
6792                 return -KEY_atan2;
6793               }
6794
6795               goto unknown;
6796
6797             default:
6798               goto unknown;
6799           }
6800
6801         case 'b':
6802           switch (name[1])
6803           {
6804             case 'l':
6805               if (name[2] == 'e' &&
6806               name[3] == 's' &&
6807               name[4] == 's')
6808           {                                       /* bless      */
6809             return -KEY_bless;
6810           }
6811
6812           goto unknown;
6813
6814             case 'r':
6815               if (name[2] == 'e' &&
6816                   name[3] == 'a' &&
6817                   name[4] == 'k')
6818               {                                   /* break      */
6819                 return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
6820               }
6821
6822               goto unknown;
6823
6824             default:
6825               goto unknown;
6826           }
6827
6828         case 'c':
6829           switch (name[1])
6830           {
6831             case 'h':
6832               switch (name[2])
6833               {
6834                 case 'd':
6835                   if (name[3] == 'i' &&
6836                       name[4] == 'r')
6837                   {                               /* chdir      */
6838                     return -KEY_chdir;
6839                   }
6840
6841                   goto unknown;
6842
6843                 case 'm':
6844                   if (name[3] == 'o' &&
6845                       name[4] == 'd')
6846                   {                               /* chmod      */
6847                     return -KEY_chmod;
6848                   }
6849
6850                   goto unknown;
6851
6852                 case 'o':
6853                   switch (name[3])
6854                   {
6855                     case 'm':
6856                       if (name[4] == 'p')
6857                       {                           /* chomp      */
6858                         return -KEY_chomp;
6859                       }
6860
6861                       goto unknown;
6862
6863                     case 'w':
6864                       if (name[4] == 'n')
6865                       {                           /* chown      */
6866                         return -KEY_chown;
6867                       }
6868
6869                       goto unknown;
6870
6871                     default:
6872                       goto unknown;
6873                   }
6874
6875                 default:
6876                   goto unknown;
6877               }
6878
6879             case 'l':
6880               if (name[2] == 'o' &&
6881                   name[3] == 's' &&
6882                   name[4] == 'e')
6883               {                                   /* close      */
6884                 return -KEY_close;
6885               }
6886
6887               goto unknown;
6888
6889             case 'r':
6890               if (name[2] == 'y' &&
6891                   name[3] == 'p' &&
6892                   name[4] == 't')
6893               {                                   /* crypt      */
6894                 return -KEY_crypt;
6895               }
6896
6897               goto unknown;
6898
6899             default:
6900               goto unknown;
6901           }
6902
6903         case 'e':
6904           if (name[1] == 'l' &&
6905               name[2] == 's' &&
6906               name[3] == 'i' &&
6907               name[4] == 'f')
6908           {                                       /* elsif      */
6909             return KEY_elsif;
6910           }
6911
6912           goto unknown;
6913
6914         case 'f':
6915           switch (name[1])
6916           {
6917             case 'c':
6918               if (name[2] == 'n' &&
6919                   name[3] == 't' &&
6920                   name[4] == 'l')
6921               {                                   /* fcntl      */
6922                 return -KEY_fcntl;
6923               }
6924
6925               goto unknown;
6926
6927             case 'l':
6928               if (name[2] == 'o' &&
6929                   name[3] == 'c' &&
6930                   name[4] == 'k')
6931               {                                   /* flock      */
6932                 return -KEY_flock;
6933               }
6934
6935               goto unknown;
6936
6937             default:
6938               goto unknown;
6939           }
6940
6941         case 'g':
6942           if (name[1] == 'i' &&
6943               name[2] == 'v' &&
6944               name[3] == 'e' &&
6945               name[4] == 'n')
6946           {                                       /* given      */
6947             return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
6948           }
6949
6950           goto unknown;
6951
6952         case 'i':
6953           switch (name[1])
6954           {
6955             case 'n':
6956               if (name[2] == 'd' &&
6957                   name[3] == 'e' &&
6958                   name[4] == 'x')
6959               {                                   /* index      */
6960                 return -KEY_index;
6961               }
6962
6963               goto unknown;
6964
6965             case 'o':
6966               if (name[2] == 'c' &&
6967                   name[3] == 't' &&
6968                   name[4] == 'l')
6969               {                                   /* ioctl      */
6970                 return -KEY_ioctl;
6971               }
6972
6973               goto unknown;
6974
6975             default:
6976               goto unknown;
6977           }
6978
6979         case 'l':
6980           switch (name[1])
6981           {
6982             case 'o':
6983               if (name[2] == 'c' &&
6984                   name[3] == 'a' &&
6985                   name[4] == 'l')
6986               {                                   /* local      */
6987                 return KEY_local;
6988               }
6989
6990               goto unknown;
6991
6992             case 's':
6993               if (name[2] == 't' &&
6994                   name[3] == 'a' &&
6995                   name[4] == 't')
6996               {                                   /* lstat      */
6997                 return -KEY_lstat;
6998               }
6999
7000               goto unknown;
7001
7002             default:
7003               goto unknown;
7004           }
7005
7006         case 'm':
7007           if (name[1] == 'k' &&
7008               name[2] == 'd' &&
7009               name[3] == 'i' &&
7010               name[4] == 'r')
7011           {                                       /* mkdir      */
7012             return -KEY_mkdir;
7013           }
7014
7015           goto unknown;
7016
7017         case 'p':
7018           if (name[1] == 'r' &&
7019               name[2] == 'i' &&
7020               name[3] == 'n' &&
7021               name[4] == 't')
7022           {                                       /* print      */
7023             return KEY_print;
7024           }
7025
7026           goto unknown;
7027
7028         case 'r':
7029           switch (name[1])
7030           {
7031             case 'e':
7032               if (name[2] == 's' &&
7033                   name[3] == 'e' &&
7034                   name[4] == 't')
7035               {                                   /* reset      */
7036                 return -KEY_reset;
7037               }
7038
7039               goto unknown;
7040
7041             case 'm':
7042               if (name[2] == 'd' &&
7043                   name[3] == 'i' &&
7044                   name[4] == 'r')
7045               {                                   /* rmdir      */
7046                 return -KEY_rmdir;
7047               }
7048
7049               goto unknown;
7050
7051             default:
7052               goto unknown;
7053           }
7054
7055         case 's':
7056           switch (name[1])
7057           {
7058             case 'e':
7059               if (name[2] == 'm' &&
7060                   name[3] == 'o' &&
7061                   name[4] == 'p')
7062               {                                   /* semop      */
7063                 return -KEY_semop;
7064               }
7065
7066               goto unknown;
7067
7068             case 'h':
7069               if (name[2] == 'i' &&
7070                   name[3] == 'f' &&
7071                   name[4] == 't')
7072               {                                   /* shift      */
7073                 return -KEY_shift;
7074               }
7075
7076               goto unknown;
7077
7078             case 'l':
7079               if (name[2] == 'e' &&
7080                   name[3] == 'e' &&
7081                   name[4] == 'p')
7082               {                                   /* sleep      */
7083                 return -KEY_sleep;
7084               }
7085
7086               goto unknown;
7087
7088             case 'p':
7089               if (name[2] == 'l' &&
7090                   name[3] == 'i' &&
7091                   name[4] == 't')
7092               {                                   /* split      */
7093                 return KEY_split;
7094               }
7095
7096               goto unknown;
7097
7098             case 'r':
7099               if (name[2] == 'a' &&
7100                   name[3] == 'n' &&
7101                   name[4] == 'd')
7102               {                                   /* srand      */
7103                 return -KEY_srand;
7104               }
7105
7106               goto unknown;
7107
7108             case 't':
7109               if (name[2] == 'u' &&
7110                   name[3] == 'd' &&
7111                   name[4] == 'y')
7112               {                                   /* study      */
7113                 return KEY_study;
7114               }
7115
7116               goto unknown;
7117
7118             default:
7119               goto unknown;
7120           }
7121
7122         case 't':
7123           if (name[1] == 'i' &&
7124               name[2] == 'm' &&
7125               name[3] == 'e' &&
7126               name[4] == 's')
7127           {                                       /* times      */
7128             return -KEY_times;
7129           }
7130
7131           goto unknown;
7132
7133         case 'u':
7134           switch (name[1])
7135           {
7136             case 'm':
7137               if (name[2] == 'a' &&
7138                   name[3] == 's' &&
7139                   name[4] == 'k')
7140               {                                   /* umask      */
7141                 return -KEY_umask;
7142               }
7143
7144               goto unknown;
7145
7146             case 'n':
7147               switch (name[2])
7148               {
7149                 case 'd':
7150                   if (name[3] == 'e' &&
7151                       name[4] == 'f')
7152                   {                               /* undef      */
7153                     return KEY_undef;
7154                   }
7155
7156                   goto unknown;
7157
7158                 case 't':
7159                   if (name[3] == 'i')
7160                   {
7161                     switch (name[4])
7162                     {
7163                       case 'e':
7164                         {                         /* untie      */
7165                           return KEY_untie;
7166                         }
7167
7168                       case 'l':
7169                         {                         /* until      */
7170                           return KEY_until;
7171                         }
7172
7173                       default:
7174                         goto unknown;
7175                     }
7176                   }
7177
7178                   goto unknown;
7179
7180                 default:
7181                   goto unknown;
7182               }
7183
7184             case 't':
7185               if (name[2] == 'i' &&
7186                   name[3] == 'm' &&
7187                   name[4] == 'e')
7188               {                                   /* utime      */
7189                 return -KEY_utime;
7190               }
7191
7192               goto unknown;
7193
7194             default:
7195               goto unknown;
7196           }
7197
7198         case 'w':
7199           switch (name[1])
7200           {
7201             case 'h':
7202               if (name[2] == 'i' &&
7203                   name[3] == 'l' &&
7204                   name[4] == 'e')
7205               {                                   /* while      */
7206                 return KEY_while;
7207               }
7208
7209               goto unknown;
7210
7211             case 'r':
7212               if (name[2] == 'i' &&
7213                   name[3] == 't' &&
7214                   name[4] == 'e')
7215               {                                   /* write      */
7216                 return -KEY_write;
7217               }
7218
7219               goto unknown;
7220
7221             default:
7222               goto unknown;
7223           }
7224
7225         default:
7226           goto unknown;
7227       }
7228
7229     case 6: /* 33 tokens of length 6 */
7230       switch (name[0])
7231       {
7232         case 'a':
7233           if (name[1] == 'c' &&
7234               name[2] == 'c' &&
7235               name[3] == 'e' &&
7236               name[4] == 'p' &&
7237               name[5] == 't')
7238           {                                       /* accept     */
7239             return -KEY_accept;
7240           }
7241
7242           goto unknown;
7243
7244         case 'c':
7245           switch (name[1])
7246           {
7247             case 'a':
7248               if (name[2] == 'l' &&
7249                   name[3] == 'l' &&
7250                   name[4] == 'e' &&
7251                   name[5] == 'r')
7252               {                                   /* caller     */
7253                 return -KEY_caller;
7254               }
7255
7256               goto unknown;
7257
7258             case 'h':
7259               if (name[2] == 'r' &&
7260                   name[3] == 'o' &&
7261                   name[4] == 'o' &&
7262                   name[5] == 't')
7263               {                                   /* chroot     */
7264                 return -KEY_chroot;
7265               }
7266
7267               goto unknown;
7268
7269             default:
7270               goto unknown;
7271           }
7272
7273         case 'd':
7274           if (name[1] == 'e' &&
7275               name[2] == 'l' &&
7276               name[3] == 'e' &&
7277               name[4] == 't' &&
7278               name[5] == 'e')
7279           {                                       /* delete     */
7280             return KEY_delete;
7281           }
7282
7283           goto unknown;
7284
7285         case 'e':
7286           switch (name[1])
7287           {
7288             case 'l':
7289               if (name[2] == 's' &&
7290                   name[3] == 'e' &&
7291                   name[4] == 'i' &&
7292                   name[5] == 'f')
7293               {                                   /* elseif     */
7294                 if(ckWARN_d(WARN_SYNTAX))
7295                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7296               }
7297
7298               goto unknown;
7299
7300             case 'x':
7301               if (name[2] == 'i' &&
7302                   name[3] == 's' &&
7303                   name[4] == 't' &&
7304                   name[5] == 's')
7305               {                                   /* exists     */
7306                 return KEY_exists;
7307               }
7308
7309               goto unknown;
7310
7311             default:
7312               goto unknown;
7313           }
7314
7315         case 'f':
7316           switch (name[1])
7317           {
7318             case 'i':
7319               if (name[2] == 'l' &&
7320                   name[3] == 'e' &&
7321                   name[4] == 'n' &&
7322                   name[5] == 'o')
7323               {                                   /* fileno     */
7324                 return -KEY_fileno;
7325               }
7326
7327               goto unknown;
7328
7329             case 'o':
7330               if (name[2] == 'r' &&
7331                   name[3] == 'm' &&
7332                   name[4] == 'a' &&
7333                   name[5] == 't')
7334               {                                   /* format     */
7335                 return KEY_format;
7336               }
7337
7338               goto unknown;
7339
7340             default:
7341               goto unknown;
7342           }
7343
7344         case 'g':
7345           if (name[1] == 'm' &&
7346               name[2] == 't' &&
7347               name[3] == 'i' &&
7348               name[4] == 'm' &&
7349               name[5] == 'e')
7350           {                                       /* gmtime     */
7351             return -KEY_gmtime;
7352           }
7353
7354           goto unknown;
7355
7356         case 'l':
7357           switch (name[1])
7358           {
7359             case 'e':
7360               if (name[2] == 'n' &&
7361                   name[3] == 'g' &&
7362                   name[4] == 't' &&
7363                   name[5] == 'h')
7364               {                                   /* length     */
7365                 return -KEY_length;
7366               }
7367
7368               goto unknown;
7369
7370             case 'i':
7371               if (name[2] == 's' &&
7372                   name[3] == 't' &&
7373                   name[4] == 'e' &&
7374                   name[5] == 'n')
7375               {                                   /* listen     */
7376                 return -KEY_listen;
7377               }
7378
7379               goto unknown;
7380
7381             default:
7382               goto unknown;
7383           }
7384
7385         case 'm':
7386           if (name[1] == 's' &&
7387               name[2] == 'g')
7388           {
7389             switch (name[3])
7390             {
7391               case 'c':
7392                 if (name[4] == 't' &&
7393                     name[5] == 'l')
7394                 {                                 /* msgctl     */
7395                   return -KEY_msgctl;
7396                 }
7397
7398                 goto unknown;
7399
7400               case 'g':
7401                 if (name[4] == 'e' &&
7402                     name[5] == 't')
7403                 {                                 /* msgget     */
7404                   return -KEY_msgget;
7405                 }
7406
7407                 goto unknown;
7408
7409               case 'r':
7410                 if (name[4] == 'c' &&
7411                     name[5] == 'v')
7412                 {                                 /* msgrcv     */
7413                   return -KEY_msgrcv;
7414                 }
7415
7416                 goto unknown;
7417
7418               case 's':
7419                 if (name[4] == 'n' &&
7420                     name[5] == 'd')
7421                 {                                 /* msgsnd     */
7422                   return -KEY_msgsnd;
7423                 }
7424
7425                 goto unknown;
7426
7427               default:
7428                 goto unknown;
7429             }
7430           }
7431
7432           goto unknown;
7433
7434         case 'p':
7435           if (name[1] == 'r' &&
7436               name[2] == 'i' &&
7437               name[3] == 'n' &&
7438               name[4] == 't' &&
7439               name[5] == 'f')
7440           {                                       /* printf     */
7441             return KEY_printf;
7442           }
7443
7444           goto unknown;
7445
7446         case 'r':
7447           switch (name[1])
7448           {
7449             case 'e':
7450               switch (name[2])
7451               {
7452                 case 'n':
7453                   if (name[3] == 'a' &&
7454                       name[4] == 'm' &&
7455                       name[5] == 'e')
7456                   {                               /* rename     */
7457                     return -KEY_rename;
7458                   }
7459
7460                   goto unknown;
7461
7462                 case 't':
7463                   if (name[3] == 'u' &&
7464                       name[4] == 'r' &&
7465                       name[5] == 'n')
7466                   {                               /* return     */
7467                     return KEY_return;
7468                   }
7469
7470                   goto unknown;
7471
7472                 default:
7473                   goto unknown;
7474               }
7475
7476             case 'i':
7477               if (name[2] == 'n' &&
7478                   name[3] == 'd' &&
7479                   name[4] == 'e' &&
7480                   name[5] == 'x')
7481               {                                   /* rindex     */
7482                 return -KEY_rindex;
7483               }
7484
7485               goto unknown;
7486
7487             default:
7488               goto unknown;
7489           }
7490
7491         case 's':
7492           switch (name[1])
7493           {
7494             case 'c':
7495               if (name[2] == 'a' &&
7496                   name[3] == 'l' &&
7497                   name[4] == 'a' &&
7498                   name[5] == 'r')
7499               {                                   /* scalar     */
7500                 return KEY_scalar;
7501               }
7502
7503               goto unknown;
7504
7505             case 'e':
7506               switch (name[2])
7507               {
7508                 case 'l':
7509                   if (name[3] == 'e' &&
7510                       name[4] == 'c' &&
7511                       name[5] == 't')
7512                   {                               /* select     */
7513                     return -KEY_select;
7514                   }
7515
7516                   goto unknown;
7517
7518                 case 'm':
7519                   switch (name[3])
7520                   {
7521                     case 'c':
7522                       if (name[4] == 't' &&
7523                           name[5] == 'l')
7524                       {                           /* semctl     */
7525                         return -KEY_semctl;
7526                       }
7527
7528                       goto unknown;
7529
7530                     case 'g':
7531                       if (name[4] == 'e' &&
7532                           name[5] == 't')
7533                       {                           /* semget     */
7534                         return -KEY_semget;
7535                       }
7536
7537                       goto unknown;
7538
7539                     default:
7540                       goto unknown;
7541                   }
7542
7543                 default:
7544                   goto unknown;
7545               }
7546
7547             case 'h':
7548               if (name[2] == 'm')
7549               {
7550                 switch (name[3])
7551                 {
7552                   case 'c':
7553                     if (name[4] == 't' &&
7554                         name[5] == 'l')
7555                     {                             /* shmctl     */
7556                       return -KEY_shmctl;
7557                     }
7558
7559                     goto unknown;
7560
7561                   case 'g':
7562                     if (name[4] == 'e' &&
7563                         name[5] == 't')
7564                     {                             /* shmget     */
7565                       return -KEY_shmget;
7566                     }
7567
7568                     goto unknown;
7569
7570                   default:
7571                     goto unknown;
7572                 }
7573               }
7574
7575               goto unknown;
7576
7577             case 'o':
7578               if (name[2] == 'c' &&
7579                   name[3] == 'k' &&
7580                   name[4] == 'e' &&
7581                   name[5] == 't')
7582               {                                   /* socket     */
7583                 return -KEY_socket;
7584               }
7585
7586               goto unknown;
7587
7588             case 'p':
7589               if (name[2] == 'l' &&
7590                   name[3] == 'i' &&
7591                   name[4] == 'c' &&
7592                   name[5] == 'e')
7593               {                                   /* splice     */
7594                 return -KEY_splice;
7595               }
7596
7597               goto unknown;
7598
7599             case 'u':
7600               if (name[2] == 'b' &&
7601                   name[3] == 's' &&
7602                   name[4] == 't' &&
7603                   name[5] == 'r')
7604               {                                   /* substr     */
7605                 return -KEY_substr;
7606               }
7607
7608               goto unknown;
7609
7610             case 'y':
7611               if (name[2] == 's' &&
7612                   name[3] == 't' &&
7613                   name[4] == 'e' &&
7614                   name[5] == 'm')
7615               {                                   /* system     */
7616                 return -KEY_system;
7617               }
7618
7619               goto unknown;
7620
7621             default:
7622               goto unknown;
7623           }
7624
7625         case 'u':
7626           if (name[1] == 'n')
7627           {
7628             switch (name[2])
7629             {
7630               case 'l':
7631                 switch (name[3])
7632                 {
7633                   case 'e':
7634                     if (name[4] == 's' &&
7635                         name[5] == 's')
7636                     {                             /* unless     */
7637                       return KEY_unless;
7638                     }
7639
7640                     goto unknown;
7641
7642                   case 'i':
7643                     if (name[4] == 'n' &&
7644                         name[5] == 'k')
7645                     {                             /* unlink     */
7646                       return -KEY_unlink;
7647                     }
7648
7649                     goto unknown;
7650
7651                   default:
7652                     goto unknown;
7653                 }
7654
7655               case 'p':
7656                 if (name[3] == 'a' &&
7657                     name[4] == 'c' &&
7658                     name[5] == 'k')
7659                 {                                 /* unpack     */
7660                   return -KEY_unpack;
7661                 }
7662
7663                 goto unknown;
7664
7665               default:
7666                 goto unknown;
7667             }
7668           }
7669
7670           goto unknown;
7671
7672         case 'v':
7673           if (name[1] == 'a' &&
7674               name[2] == 'l' &&
7675               name[3] == 'u' &&
7676               name[4] == 'e' &&
7677               name[5] == 's')
7678           {                                       /* values     */
7679             return -KEY_values;
7680           }
7681
7682           goto unknown;
7683
7684         default:
7685           goto unknown;
7686       }
7687
7688     case 7: /* 29 tokens of length 7 */
7689       switch (name[0])
7690       {
7691         case 'D':
7692           if (name[1] == 'E' &&
7693               name[2] == 'S' &&
7694               name[3] == 'T' &&
7695               name[4] == 'R' &&
7696               name[5] == 'O' &&
7697               name[6] == 'Y')
7698           {                                       /* DESTROY    */
7699             return KEY_DESTROY;
7700           }
7701
7702           goto unknown;
7703
7704         case '_':
7705           if (name[1] == '_' &&
7706               name[2] == 'E' &&
7707               name[3] == 'N' &&
7708               name[4] == 'D' &&
7709               name[5] == '_' &&
7710               name[6] == '_')
7711           {                                       /* __END__    */
7712             return KEY___END__;
7713           }
7714
7715           goto unknown;
7716
7717         case 'b':
7718           if (name[1] == 'i' &&
7719               name[2] == 'n' &&
7720               name[3] == 'm' &&
7721               name[4] == 'o' &&
7722               name[5] == 'd' &&
7723               name[6] == 'e')
7724           {                                       /* binmode    */
7725             return -KEY_binmode;
7726           }
7727
7728           goto unknown;
7729
7730         case 'c':
7731           if (name[1] == 'o' &&
7732               name[2] == 'n' &&
7733               name[3] == 'n' &&
7734               name[4] == 'e' &&
7735               name[5] == 'c' &&
7736               name[6] == 't')
7737           {                                       /* connect    */
7738             return -KEY_connect;
7739           }
7740
7741           goto unknown;
7742
7743         case 'd':
7744           switch (name[1])
7745           {
7746             case 'b':
7747               if (name[2] == 'm' &&
7748                   name[3] == 'o' &&
7749                   name[4] == 'p' &&
7750                   name[5] == 'e' &&
7751                   name[6] == 'n')
7752               {                                   /* dbmopen    */
7753                 return -KEY_dbmopen;
7754               }
7755
7756               goto unknown;
7757
7758             case 'e':
7759               if (name[2] == 'f')
7760               {
7761                 switch (name[3])
7762                 {
7763                   case 'a':
7764                     if (name[4] == 'u' &&
7765                         name[5] == 'l' &&
7766                         name[6] == 't')
7767                     {                             /* default    */
7768                       return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
7769                     }
7770
7771                     goto unknown;
7772
7773                   case 'i':
7774                     if (name[4] == 'n' &&
7775                   name[5] == 'e' &&
7776                   name[6] == 'd')
7777               {                                   /* defined    */
7778                 return KEY_defined;
7779               }
7780
7781               goto unknown;
7782
7783             default:
7784               goto unknown;
7785           }
7786               }
7787
7788               goto unknown;
7789
7790             default:
7791               goto unknown;
7792           }
7793
7794         case 'f':
7795           if (name[1] == 'o' &&
7796               name[2] == 'r' &&
7797               name[3] == 'e' &&
7798               name[4] == 'a' &&
7799               name[5] == 'c' &&
7800               name[6] == 'h')
7801           {                                       /* foreach    */
7802             return KEY_foreach;
7803           }
7804
7805           goto unknown;
7806
7807         case 'g':
7808           if (name[1] == 'e' &&
7809               name[2] == 't' &&
7810               name[3] == 'p')
7811           {
7812             switch (name[4])
7813             {
7814               case 'g':
7815                 if (name[5] == 'r' &&
7816                     name[6] == 'p')
7817                 {                                 /* getpgrp    */
7818                   return -KEY_getpgrp;
7819                 }
7820
7821                 goto unknown;
7822
7823               case 'p':
7824                 if (name[5] == 'i' &&
7825                     name[6] == 'd')
7826                 {                                 /* getppid    */
7827                   return -KEY_getppid;
7828                 }
7829
7830                 goto unknown;
7831
7832               default:
7833                 goto unknown;
7834             }
7835           }
7836
7837           goto unknown;
7838
7839         case 'l':
7840           if (name[1] == 'c' &&
7841               name[2] == 'f' &&
7842               name[3] == 'i' &&
7843               name[4] == 'r' &&
7844               name[5] == 's' &&
7845               name[6] == 't')
7846           {                                       /* lcfirst    */
7847             return -KEY_lcfirst;
7848           }
7849
7850           goto unknown;
7851
7852         case 'o':
7853           if (name[1] == 'p' &&
7854               name[2] == 'e' &&
7855               name[3] == 'n' &&
7856               name[4] == 'd' &&
7857               name[5] == 'i' &&
7858               name[6] == 'r')
7859           {                                       /* opendir    */
7860             return -KEY_opendir;
7861           }
7862
7863           goto unknown;
7864
7865         case 'p':
7866           if (name[1] == 'a' &&
7867               name[2] == 'c' &&
7868               name[3] == 'k' &&
7869               name[4] == 'a' &&
7870               name[5] == 'g' &&
7871               name[6] == 'e')
7872           {                                       /* package    */
7873             return KEY_package;
7874           }
7875
7876           goto unknown;
7877
7878         case 'r':
7879           if (name[1] == 'e')
7880           {
7881             switch (name[2])
7882             {
7883               case 'a':
7884                 if (name[3] == 'd' &&
7885                     name[4] == 'd' &&
7886                     name[5] == 'i' &&
7887                     name[6] == 'r')
7888                 {                                 /* readdir    */
7889                   return -KEY_readdir;
7890                 }
7891
7892                 goto unknown;
7893
7894               case 'q':
7895                 if (name[3] == 'u' &&
7896                     name[4] == 'i' &&
7897                     name[5] == 'r' &&
7898                     name[6] == 'e')
7899                 {                                 /* require    */
7900                   return KEY_require;
7901                 }
7902
7903                 goto unknown;
7904
7905               case 'v':
7906                 if (name[3] == 'e' &&
7907                     name[4] == 'r' &&
7908                     name[5] == 's' &&
7909                     name[6] == 'e')
7910                 {                                 /* reverse    */
7911                   return -KEY_reverse;
7912                 }
7913
7914                 goto unknown;
7915
7916               default:
7917                 goto unknown;
7918             }
7919           }
7920
7921           goto unknown;
7922
7923         case 's':
7924           switch (name[1])
7925           {
7926             case 'e':
7927               switch (name[2])
7928               {
7929                 case 'e':
7930                   if (name[3] == 'k' &&
7931                       name[4] == 'd' &&
7932                       name[5] == 'i' &&
7933                       name[6] == 'r')
7934                   {                               /* seekdir    */
7935                     return -KEY_seekdir;
7936                   }
7937
7938                   goto unknown;
7939
7940                 case 't':
7941                   if (name[3] == 'p' &&
7942                       name[4] == 'g' &&
7943                       name[5] == 'r' &&
7944                       name[6] == 'p')
7945                   {                               /* setpgrp    */
7946                     return -KEY_setpgrp;
7947                   }
7948
7949                   goto unknown;
7950
7951                 default:
7952                   goto unknown;
7953               }
7954
7955             case 'h':
7956               if (name[2] == 'm' &&
7957                   name[3] == 'r' &&
7958                   name[4] == 'e' &&
7959                   name[5] == 'a' &&
7960                   name[6] == 'd')
7961               {                                   /* shmread    */
7962                 return -KEY_shmread;
7963               }
7964
7965               goto unknown;
7966
7967             case 'p':
7968               if (name[2] == 'r' &&
7969                   name[3] == 'i' &&
7970                   name[4] == 'n' &&
7971                   name[5] == 't' &&
7972                   name[6] == 'f')
7973               {                                   /* sprintf    */
7974                 return -KEY_sprintf;
7975               }
7976
7977               goto unknown;
7978
7979             case 'y':
7980               switch (name[2])
7981               {
7982                 case 'm':
7983                   if (name[3] == 'l' &&
7984                       name[4] == 'i' &&
7985                       name[5] == 'n' &&
7986                       name[6] == 'k')
7987                   {                               /* symlink    */
7988                     return -KEY_symlink;
7989                   }
7990
7991                   goto unknown;
7992
7993                 case 's':
7994                   switch (name[3])
7995                   {
7996                     case 'c':
7997                       if (name[4] == 'a' &&
7998                           name[5] == 'l' &&
7999                           name[6] == 'l')
8000                       {                           /* syscall    */
8001                         return -KEY_syscall;
8002                       }
8003
8004                       goto unknown;
8005
8006                     case 'o':
8007                       if (name[4] == 'p' &&
8008                           name[5] == 'e' &&
8009                           name[6] == 'n')
8010                       {                           /* sysopen    */
8011                         return -KEY_sysopen;
8012                       }
8013
8014                       goto unknown;
8015
8016                     case 'r':
8017                       if (name[4] == 'e' &&
8018                           name[5] == 'a' &&
8019                           name[6] == 'd')
8020                       {                           /* sysread    */
8021                         return -KEY_sysread;
8022                       }
8023
8024                       goto unknown;
8025
8026                     case 's':
8027                       if (name[4] == 'e' &&
8028                           name[5] == 'e' &&
8029                           name[6] == 'k')
8030                       {                           /* sysseek    */
8031                         return -KEY_sysseek;
8032                       }
8033
8034                       goto unknown;
8035
8036                     default:
8037                       goto unknown;
8038                   }
8039
8040                 default:
8041                   goto unknown;
8042               }
8043
8044             default:
8045               goto unknown;
8046           }
8047
8048         case 't':
8049           if (name[1] == 'e' &&
8050               name[2] == 'l' &&
8051               name[3] == 'l' &&
8052               name[4] == 'd' &&
8053               name[5] == 'i' &&
8054               name[6] == 'r')
8055           {                                       /* telldir    */
8056             return -KEY_telldir;
8057           }
8058
8059           goto unknown;
8060
8061         case 'u':
8062           switch (name[1])
8063           {
8064             case 'c':
8065               if (name[2] == 'f' &&
8066                   name[3] == 'i' &&
8067                   name[4] == 'r' &&
8068                   name[5] == 's' &&
8069                   name[6] == 't')
8070               {                                   /* ucfirst    */
8071                 return -KEY_ucfirst;
8072               }
8073
8074               goto unknown;
8075
8076             case 'n':
8077               if (name[2] == 's' &&
8078                   name[3] == 'h' &&
8079                   name[4] == 'i' &&
8080                   name[5] == 'f' &&
8081                   name[6] == 't')
8082               {                                   /* unshift    */
8083                 return -KEY_unshift;
8084               }
8085
8086               goto unknown;
8087
8088             default:
8089               goto unknown;
8090           }
8091
8092         case 'w':
8093           if (name[1] == 'a' &&
8094               name[2] == 'i' &&
8095               name[3] == 't' &&
8096               name[4] == 'p' &&
8097               name[5] == 'i' &&
8098               name[6] == 'd')
8099           {                                       /* waitpid    */
8100             return -KEY_waitpid;
8101           }
8102
8103           goto unknown;
8104
8105         default:
8106           goto unknown;
8107       }
8108
8109     case 8: /* 26 tokens of length 8 */
8110       switch (name[0])
8111       {
8112         case 'A':
8113           if (name[1] == 'U' &&
8114               name[2] == 'T' &&
8115               name[3] == 'O' &&
8116               name[4] == 'L' &&
8117               name[5] == 'O' &&
8118               name[6] == 'A' &&
8119               name[7] == 'D')
8120           {                                       /* AUTOLOAD   */
8121             return KEY_AUTOLOAD;
8122           }
8123
8124           goto unknown;
8125
8126         case '_':
8127           if (name[1] == '_')
8128           {
8129             switch (name[2])
8130             {
8131               case 'D':
8132                 if (name[3] == 'A' &&
8133                     name[4] == 'T' &&
8134                     name[5] == 'A' &&
8135                     name[6] == '_' &&
8136                     name[7] == '_')
8137                 {                                 /* __DATA__   */
8138                   return KEY___DATA__;
8139                 }
8140
8141                 goto unknown;
8142
8143               case 'F':
8144                 if (name[3] == 'I' &&
8145                     name[4] == 'L' &&
8146                     name[5] == 'E' &&
8147                     name[6] == '_' &&
8148                     name[7] == '_')
8149                 {                                 /* __FILE__   */
8150                   return -KEY___FILE__;
8151                 }
8152
8153                 goto unknown;
8154
8155               case 'L':
8156                 if (name[3] == 'I' &&
8157                     name[4] == 'N' &&
8158                     name[5] == 'E' &&
8159                     name[6] == '_' &&
8160                     name[7] == '_')
8161                 {                                 /* __LINE__   */
8162                   return -KEY___LINE__;
8163                 }
8164
8165                 goto unknown;
8166
8167               default:
8168                 goto unknown;
8169             }
8170           }
8171
8172           goto unknown;
8173
8174         case 'c':
8175           switch (name[1])
8176           {
8177             case 'l':
8178               if (name[2] == 'o' &&
8179                   name[3] == 's' &&
8180                   name[4] == 'e' &&
8181                   name[5] == 'd' &&
8182                   name[6] == 'i' &&
8183                   name[7] == 'r')
8184               {                                   /* closedir   */
8185                 return -KEY_closedir;
8186               }
8187
8188               goto unknown;
8189
8190             case 'o':
8191               if (name[2] == 'n' &&
8192                   name[3] == 't' &&
8193                   name[4] == 'i' &&
8194                   name[5] == 'n' &&
8195                   name[6] == 'u' &&
8196                   name[7] == 'e')
8197               {                                   /* continue   */
8198                 return -KEY_continue;
8199               }
8200
8201               goto unknown;
8202
8203             default:
8204               goto unknown;
8205           }
8206
8207         case 'd':
8208           if (name[1] == 'b' &&
8209               name[2] == 'm' &&
8210               name[3] == 'c' &&
8211               name[4] == 'l' &&
8212               name[5] == 'o' &&
8213               name[6] == 's' &&
8214               name[7] == 'e')
8215           {                                       /* dbmclose   */
8216             return -KEY_dbmclose;
8217           }
8218
8219           goto unknown;
8220
8221         case 'e':
8222           if (name[1] == 'n' &&
8223               name[2] == 'd')
8224           {
8225             switch (name[3])
8226             {
8227               case 'g':
8228                 if (name[4] == 'r' &&
8229                     name[5] == 'e' &&
8230                     name[6] == 'n' &&
8231                     name[7] == 't')
8232                 {                                 /* endgrent   */
8233                   return -KEY_endgrent;
8234                 }
8235
8236                 goto unknown;
8237
8238               case 'p':
8239                 if (name[4] == 'w' &&
8240                     name[5] == 'e' &&
8241                     name[6] == 'n' &&
8242                     name[7] == 't')
8243                 {                                 /* endpwent   */
8244                   return -KEY_endpwent;
8245                 }
8246
8247                 goto unknown;
8248
8249               default:
8250                 goto unknown;
8251             }
8252           }
8253
8254           goto unknown;
8255
8256         case 'f':
8257           if (name[1] == 'o' &&
8258               name[2] == 'r' &&
8259               name[3] == 'm' &&
8260               name[4] == 'l' &&
8261               name[5] == 'i' &&
8262               name[6] == 'n' &&
8263               name[7] == 'e')
8264           {                                       /* formline   */
8265             return -KEY_formline;
8266           }
8267
8268           goto unknown;
8269
8270         case 'g':
8271           if (name[1] == 'e' &&
8272               name[2] == 't')
8273           {
8274             switch (name[3])
8275             {
8276               case 'g':
8277                 if (name[4] == 'r')
8278                 {
8279                   switch (name[5])
8280                   {
8281                     case 'e':
8282                       if (name[6] == 'n' &&
8283                           name[7] == 't')
8284                       {                           /* getgrent   */
8285                         return -KEY_getgrent;
8286                       }
8287
8288                       goto unknown;
8289
8290                     case 'g':
8291                       if (name[6] == 'i' &&
8292                           name[7] == 'd')
8293                       {                           /* getgrgid   */
8294                         return -KEY_getgrgid;
8295                       }
8296
8297                       goto unknown;
8298
8299                     case 'n':
8300                       if (name[6] == 'a' &&
8301                           name[7] == 'm')
8302                       {                           /* getgrnam   */
8303                         return -KEY_getgrnam;
8304                       }
8305
8306                       goto unknown;
8307
8308                     default:
8309                       goto unknown;
8310                   }
8311                 }
8312
8313                 goto unknown;
8314
8315               case 'l':
8316                 if (name[4] == 'o' &&
8317                     name[5] == 'g' &&
8318                     name[6] == 'i' &&
8319                     name[7] == 'n')
8320                 {                                 /* getlogin   */
8321                   return -KEY_getlogin;
8322                 }
8323
8324                 goto unknown;
8325
8326               case 'p':
8327                 if (name[4] == 'w')
8328                 {
8329                   switch (name[5])
8330                   {
8331                     case 'e':
8332                       if (name[6] == 'n' &&
8333                           name[7] == 't')
8334                       {                           /* getpwent   */
8335                         return -KEY_getpwent;
8336                       }
8337
8338                       goto unknown;
8339
8340                     case 'n':
8341                       if (name[6] == 'a' &&
8342                           name[7] == 'm')
8343                       {                           /* getpwnam   */
8344                         return -KEY_getpwnam;
8345                       }
8346
8347                       goto unknown;
8348
8349                     case 'u':
8350                       if (name[6] == 'i' &&
8351                           name[7] == 'd')
8352                       {                           /* getpwuid   */
8353                         return -KEY_getpwuid;
8354                       }
8355
8356                       goto unknown;
8357
8358                     default:
8359                       goto unknown;
8360                   }
8361                 }
8362
8363                 goto unknown;
8364
8365               default:
8366                 goto unknown;
8367             }
8368           }
8369
8370           goto unknown;
8371
8372         case 'r':
8373           if (name[1] == 'e' &&
8374               name[2] == 'a' &&
8375               name[3] == 'd')
8376           {
8377             switch (name[4])
8378             {
8379               case 'l':
8380                 if (name[5] == 'i' &&
8381                     name[6] == 'n')
8382                 {
8383                   switch (name[7])
8384                   {
8385                     case 'e':
8386                       {                           /* readline   */
8387                         return -KEY_readline;
8388                       }
8389
8390                     case 'k':
8391                       {                           /* readlink   */
8392                         return -KEY_readlink;
8393                       }
8394
8395                     default:
8396                       goto unknown;
8397                   }
8398                 }
8399
8400                 goto unknown;
8401
8402               case 'p':
8403                 if (name[5] == 'i' &&
8404                     name[6] == 'p' &&
8405                     name[7] == 'e')
8406                 {                                 /* readpipe   */
8407                   return -KEY_readpipe;
8408                 }
8409
8410                 goto unknown;
8411
8412               default:
8413                 goto unknown;
8414             }
8415           }
8416
8417           goto unknown;
8418
8419         case 's':
8420           switch (name[1])
8421           {
8422             case 'e':
8423               if (name[2] == 't')
8424               {
8425                 switch (name[3])
8426                 {
8427                   case 'g':
8428                     if (name[4] == 'r' &&
8429                         name[5] == 'e' &&
8430                         name[6] == 'n' &&
8431                         name[7] == 't')
8432                     {                             /* setgrent   */
8433                       return -KEY_setgrent;
8434                     }
8435
8436                     goto unknown;
8437
8438                   case 'p':
8439                     if (name[4] == 'w' &&
8440                         name[5] == 'e' &&
8441                         name[6] == 'n' &&
8442                         name[7] == 't')
8443                     {                             /* setpwent   */
8444                       return -KEY_setpwent;
8445                     }
8446
8447                     goto unknown;
8448
8449                   default:
8450                     goto unknown;
8451                 }
8452               }
8453
8454               goto unknown;
8455
8456             case 'h':
8457               switch (name[2])
8458               {
8459                 case 'm':
8460                   if (name[3] == 'w' &&
8461                       name[4] == 'r' &&
8462                       name[5] == 'i' &&
8463                       name[6] == 't' &&
8464                       name[7] == 'e')
8465                   {                               /* shmwrite   */
8466                     return -KEY_shmwrite;
8467                   }
8468
8469                   goto unknown;
8470
8471                 case 'u':
8472                   if (name[3] == 't' &&
8473                       name[4] == 'd' &&
8474                       name[5] == 'o' &&
8475                       name[6] == 'w' &&
8476                       name[7] == 'n')
8477                   {                               /* shutdown   */
8478                     return -KEY_shutdown;
8479                   }
8480
8481                   goto unknown;
8482
8483                 default:
8484                   goto unknown;
8485               }
8486
8487             case 'y':
8488               if (name[2] == 's' &&
8489                   name[3] == 'w' &&
8490                   name[4] == 'r' &&
8491                   name[5] == 'i' &&
8492                   name[6] == 't' &&
8493                   name[7] == 'e')
8494               {                                   /* syswrite   */
8495                 return -KEY_syswrite;
8496               }
8497
8498               goto unknown;
8499
8500             default:
8501               goto unknown;
8502           }
8503
8504         case 't':
8505           if (name[1] == 'r' &&
8506               name[2] == 'u' &&
8507               name[3] == 'n' &&
8508               name[4] == 'c' &&
8509               name[5] == 'a' &&
8510               name[6] == 't' &&
8511               name[7] == 'e')
8512           {                                       /* truncate   */
8513             return -KEY_truncate;
8514           }
8515
8516           goto unknown;
8517
8518         default:
8519           goto unknown;
8520       }
8521
8522     case 9: /* 8 tokens of length 9 */
8523       switch (name[0])
8524       {
8525         case 'e':
8526           if (name[1] == 'n' &&
8527               name[2] == 'd' &&
8528               name[3] == 'n' &&
8529               name[4] == 'e' &&
8530               name[5] == 't' &&
8531               name[6] == 'e' &&
8532               name[7] == 'n' &&
8533               name[8] == 't')
8534           {                                       /* endnetent  */
8535             return -KEY_endnetent;
8536           }
8537
8538           goto unknown;
8539
8540         case 'g':
8541           if (name[1] == 'e' &&
8542               name[2] == 't' &&
8543               name[3] == 'n' &&
8544               name[4] == 'e' &&
8545               name[5] == 't' &&
8546               name[6] == 'e' &&
8547               name[7] == 'n' &&
8548               name[8] == 't')
8549           {                                       /* getnetent  */
8550             return -KEY_getnetent;
8551           }
8552
8553           goto unknown;
8554
8555         case 'l':
8556           if (name[1] == 'o' &&
8557               name[2] == 'c' &&
8558               name[3] == 'a' &&
8559               name[4] == 'l' &&
8560               name[5] == 't' &&
8561               name[6] == 'i' &&
8562               name[7] == 'm' &&
8563               name[8] == 'e')
8564           {                                       /* localtime  */
8565             return -KEY_localtime;
8566           }
8567
8568           goto unknown;
8569
8570         case 'p':
8571           if (name[1] == 'r' &&
8572               name[2] == 'o' &&
8573               name[3] == 't' &&
8574               name[4] == 'o' &&
8575               name[5] == 't' &&
8576               name[6] == 'y' &&
8577               name[7] == 'p' &&
8578               name[8] == 'e')
8579           {                                       /* prototype  */
8580             return KEY_prototype;
8581           }
8582
8583           goto unknown;
8584
8585         case 'q':
8586           if (name[1] == 'u' &&
8587               name[2] == 'o' &&
8588               name[3] == 't' &&
8589               name[4] == 'e' &&
8590               name[5] == 'm' &&
8591               name[6] == 'e' &&
8592               name[7] == 't' &&
8593               name[8] == 'a')
8594           {                                       /* quotemeta  */
8595             return -KEY_quotemeta;
8596           }
8597
8598           goto unknown;
8599
8600         case 'r':
8601           if (name[1] == 'e' &&
8602               name[2] == 'w' &&
8603               name[3] == 'i' &&
8604               name[4] == 'n' &&
8605               name[5] == 'd' &&
8606               name[6] == 'd' &&
8607               name[7] == 'i' &&
8608               name[8] == 'r')
8609           {                                       /* rewinddir  */
8610             return -KEY_rewinddir;
8611           }
8612
8613           goto unknown;
8614
8615         case 's':
8616           if (name[1] == 'e' &&
8617               name[2] == 't' &&
8618               name[3] == 'n' &&
8619               name[4] == 'e' &&
8620               name[5] == 't' &&
8621               name[6] == 'e' &&
8622               name[7] == 'n' &&
8623               name[8] == 't')
8624           {                                       /* setnetent  */
8625             return -KEY_setnetent;
8626           }
8627
8628           goto unknown;
8629
8630         case 'w':
8631           if (name[1] == 'a' &&
8632               name[2] == 'n' &&
8633               name[3] == 't' &&
8634               name[4] == 'a' &&
8635               name[5] == 'r' &&
8636               name[6] == 'r' &&
8637               name[7] == 'a' &&
8638               name[8] == 'y')
8639           {                                       /* wantarray  */
8640             return -KEY_wantarray;
8641           }
8642
8643           goto unknown;
8644
8645         default:
8646           goto unknown;
8647       }
8648
8649     case 10: /* 9 tokens of length 10 */
8650       switch (name[0])
8651       {
8652         case 'e':
8653           if (name[1] == 'n' &&
8654               name[2] == 'd')
8655           {
8656             switch (name[3])
8657             {
8658               case 'h':
8659                 if (name[4] == 'o' &&
8660                     name[5] == 's' &&
8661                     name[6] == 't' &&
8662                     name[7] == 'e' &&
8663                     name[8] == 'n' &&
8664                     name[9] == 't')
8665                 {                                 /* endhostent */
8666                   return -KEY_endhostent;
8667                 }
8668
8669                 goto unknown;
8670
8671               case 's':
8672                 if (name[4] == 'e' &&
8673                     name[5] == 'r' &&
8674                     name[6] == 'v' &&
8675                     name[7] == 'e' &&
8676                     name[8] == 'n' &&
8677                     name[9] == 't')
8678                 {                                 /* endservent */
8679                   return -KEY_endservent;
8680                 }
8681
8682                 goto unknown;
8683
8684               default:
8685                 goto unknown;
8686             }
8687           }
8688
8689           goto unknown;
8690
8691         case 'g':
8692           if (name[1] == 'e' &&
8693               name[2] == 't')
8694           {
8695             switch (name[3])
8696             {
8697               case 'h':
8698                 if (name[4] == 'o' &&
8699                     name[5] == 's' &&
8700                     name[6] == 't' &&
8701                     name[7] == 'e' &&
8702                     name[8] == 'n' &&
8703                     name[9] == 't')
8704                 {                                 /* gethostent */
8705                   return -KEY_gethostent;
8706                 }
8707
8708                 goto unknown;
8709
8710               case 's':
8711                 switch (name[4])
8712                 {
8713                   case 'e':
8714                     if (name[5] == 'r' &&
8715                         name[6] == 'v' &&
8716                         name[7] == 'e' &&
8717                         name[8] == 'n' &&
8718                         name[9] == 't')
8719                     {                             /* getservent */
8720                       return -KEY_getservent;
8721                     }
8722
8723                     goto unknown;
8724
8725                   case 'o':
8726                     if (name[5] == 'c' &&
8727                         name[6] == 'k' &&
8728                         name[7] == 'o' &&
8729                         name[8] == 'p' &&
8730                         name[9] == 't')
8731                     {                             /* getsockopt */
8732                       return -KEY_getsockopt;
8733                     }
8734
8735                     goto unknown;
8736
8737                   default:
8738                     goto unknown;
8739                 }
8740
8741               default:
8742                 goto unknown;
8743             }
8744           }
8745
8746           goto unknown;
8747
8748         case 's':
8749           switch (name[1])
8750           {
8751             case 'e':
8752               if (name[2] == 't')
8753               {
8754                 switch (name[3])
8755                 {
8756                   case 'h':
8757                     if (name[4] == 'o' &&
8758                         name[5] == 's' &&
8759                         name[6] == 't' &&
8760                         name[7] == 'e' &&
8761                         name[8] == 'n' &&
8762                         name[9] == 't')
8763                     {                             /* sethostent */
8764                       return -KEY_sethostent;
8765                     }
8766
8767                     goto unknown;
8768
8769                   case 's':
8770                     switch (name[4])
8771                     {
8772                       case 'e':
8773                         if (name[5] == 'r' &&
8774                             name[6] == 'v' &&
8775                             name[7] == 'e' &&
8776                             name[8] == 'n' &&
8777                             name[9] == 't')
8778                         {                         /* setservent */
8779                           return -KEY_setservent;
8780                         }
8781
8782                         goto unknown;
8783
8784                       case 'o':
8785                         if (name[5] == 'c' &&
8786                             name[6] == 'k' &&
8787                             name[7] == 'o' &&
8788                             name[8] == 'p' &&
8789                             name[9] == 't')
8790                         {                         /* setsockopt */
8791                           return -KEY_setsockopt;
8792                         }
8793
8794                         goto unknown;
8795
8796                       default:
8797                         goto unknown;
8798                     }
8799
8800                   default:
8801                     goto unknown;
8802                 }
8803               }
8804
8805               goto unknown;
8806
8807             case 'o':
8808               if (name[2] == 'c' &&
8809                   name[3] == 'k' &&
8810                   name[4] == 'e' &&
8811                   name[5] == 't' &&
8812                   name[6] == 'p' &&
8813                   name[7] == 'a' &&
8814                   name[8] == 'i' &&
8815                   name[9] == 'r')
8816               {                                   /* socketpair */
8817                 return -KEY_socketpair;
8818               }
8819
8820               goto unknown;
8821
8822             default:
8823               goto unknown;
8824           }
8825
8826         default:
8827           goto unknown;
8828       }
8829
8830     case 11: /* 8 tokens of length 11 */
8831       switch (name[0])
8832       {
8833         case '_':
8834           if (name[1] == '_' &&
8835               name[2] == 'P' &&
8836               name[3] == 'A' &&
8837               name[4] == 'C' &&
8838               name[5] == 'K' &&
8839               name[6] == 'A' &&
8840               name[7] == 'G' &&
8841               name[8] == 'E' &&
8842               name[9] == '_' &&
8843               name[10] == '_')
8844           {                                       /* __PACKAGE__ */
8845             return -KEY___PACKAGE__;
8846           }
8847
8848           goto unknown;
8849
8850         case 'e':
8851           if (name[1] == 'n' &&
8852               name[2] == 'd' &&
8853               name[3] == 'p' &&
8854               name[4] == 'r' &&
8855               name[5] == 'o' &&
8856               name[6] == 't' &&
8857               name[7] == 'o' &&
8858               name[8] == 'e' &&
8859               name[9] == 'n' &&
8860               name[10] == 't')
8861           {                                       /* endprotoent */
8862             return -KEY_endprotoent;
8863           }
8864
8865           goto unknown;
8866
8867         case 'g':
8868           if (name[1] == 'e' &&
8869               name[2] == 't')
8870           {
8871             switch (name[3])
8872             {
8873               case 'p':
8874                 switch (name[4])
8875                 {
8876                   case 'e':
8877                     if (name[5] == 'e' &&
8878                         name[6] == 'r' &&
8879                         name[7] == 'n' &&
8880                         name[8] == 'a' &&
8881                         name[9] == 'm' &&
8882                         name[10] == 'e')
8883                     {                             /* getpeername */
8884                       return -KEY_getpeername;
8885                     }
8886
8887                     goto unknown;
8888
8889                   case 'r':
8890                     switch (name[5])
8891                     {
8892                       case 'i':
8893                         if (name[6] == 'o' &&
8894                             name[7] == 'r' &&
8895                             name[8] == 'i' &&
8896                             name[9] == 't' &&
8897                             name[10] == 'y')
8898                         {                         /* getpriority */
8899                           return -KEY_getpriority;
8900                         }
8901
8902                         goto unknown;
8903
8904                       case 'o':
8905                         if (name[6] == 't' &&
8906                             name[7] == 'o' &&
8907                             name[8] == 'e' &&
8908                             name[9] == 'n' &&
8909                             name[10] == 't')
8910                         {                         /* getprotoent */
8911                           return -KEY_getprotoent;
8912                         }
8913
8914                         goto unknown;
8915
8916                       default:
8917                         goto unknown;
8918                     }
8919
8920                   default:
8921                     goto unknown;
8922                 }
8923
8924               case 's':
8925                 if (name[4] == 'o' &&
8926                     name[5] == 'c' &&
8927                     name[6] == 'k' &&
8928                     name[7] == 'n' &&
8929                     name[8] == 'a' &&
8930                     name[9] == 'm' &&
8931                     name[10] == 'e')
8932                 {                                 /* getsockname */
8933                   return -KEY_getsockname;
8934                 }
8935
8936                 goto unknown;
8937
8938               default:
8939                 goto unknown;
8940             }
8941           }
8942
8943           goto unknown;
8944
8945         case 's':
8946           if (name[1] == 'e' &&
8947               name[2] == 't' &&
8948               name[3] == 'p' &&
8949               name[4] == 'r')
8950           {
8951             switch (name[5])
8952             {
8953               case 'i':
8954                 if (name[6] == 'o' &&
8955                     name[7] == 'r' &&
8956                     name[8] == 'i' &&
8957                     name[9] == 't' &&
8958                     name[10] == 'y')
8959                 {                                 /* setpriority */
8960                   return -KEY_setpriority;
8961                 }
8962
8963                 goto unknown;
8964
8965               case 'o':
8966                 if (name[6] == 't' &&
8967                     name[7] == 'o' &&
8968                     name[8] == 'e' &&
8969                     name[9] == 'n' &&
8970                     name[10] == 't')
8971                 {                                 /* setprotoent */
8972                   return -KEY_setprotoent;
8973                 }
8974
8975                 goto unknown;
8976
8977               default:
8978                 goto unknown;
8979             }
8980           }
8981
8982           goto unknown;
8983
8984         default:
8985           goto unknown;
8986       }
8987
8988     case 12: /* 2 tokens of length 12 */
8989       if (name[0] == 'g' &&
8990           name[1] == 'e' &&
8991           name[2] == 't' &&
8992           name[3] == 'n' &&
8993           name[4] == 'e' &&
8994           name[5] == 't' &&
8995           name[6] == 'b' &&
8996           name[7] == 'y')
8997       {
8998         switch (name[8])
8999         {
9000           case 'a':
9001             if (name[9] == 'd' &&
9002                 name[10] == 'd' &&
9003                 name[11] == 'r')
9004             {                                     /* getnetbyaddr */
9005               return -KEY_getnetbyaddr;
9006             }
9007
9008             goto unknown;
9009
9010           case 'n':
9011             if (name[9] == 'a' &&
9012                 name[10] == 'm' &&
9013                 name[11] == 'e')
9014             {                                     /* getnetbyname */
9015               return -KEY_getnetbyname;
9016             }
9017
9018             goto unknown;
9019
9020           default:
9021             goto unknown;
9022         }
9023       }
9024
9025       goto unknown;
9026
9027     case 13: /* 4 tokens of length 13 */
9028       if (name[0] == 'g' &&
9029           name[1] == 'e' &&
9030           name[2] == 't')
9031       {
9032         switch (name[3])
9033         {
9034           case 'h':
9035             if (name[4] == 'o' &&
9036                 name[5] == 's' &&
9037                 name[6] == 't' &&
9038                 name[7] == 'b' &&
9039                 name[8] == 'y')
9040             {
9041               switch (name[9])
9042               {
9043                 case 'a':
9044                   if (name[10] == 'd' &&
9045                       name[11] == 'd' &&
9046                       name[12] == 'r')
9047                   {                               /* gethostbyaddr */
9048                     return -KEY_gethostbyaddr;
9049                   }
9050
9051                   goto unknown;
9052
9053                 case 'n':
9054                   if (name[10] == 'a' &&
9055                       name[11] == 'm' &&
9056                       name[12] == 'e')
9057                   {                               /* gethostbyname */
9058                     return -KEY_gethostbyname;
9059                   }
9060
9061                   goto unknown;
9062
9063                 default:
9064                   goto unknown;
9065               }
9066             }
9067
9068             goto unknown;
9069
9070           case 's':
9071             if (name[4] == 'e' &&
9072                 name[5] == 'r' &&
9073                 name[6] == 'v' &&
9074                 name[7] == 'b' &&
9075                 name[8] == 'y')
9076             {
9077               switch (name[9])
9078               {
9079                 case 'n':
9080                   if (name[10] == 'a' &&
9081                       name[11] == 'm' &&
9082                       name[12] == 'e')
9083                   {                               /* getservbyname */
9084                     return -KEY_getservbyname;
9085                   }
9086
9087                   goto unknown;
9088
9089                 case 'p':
9090                   if (name[10] == 'o' &&
9091                       name[11] == 'r' &&
9092                       name[12] == 't')
9093                   {                               /* getservbyport */
9094                     return -KEY_getservbyport;
9095                   }
9096
9097                   goto unknown;
9098
9099                 default:
9100                   goto unknown;
9101               }
9102             }
9103
9104             goto unknown;
9105
9106           default:
9107             goto unknown;
9108         }
9109       }
9110
9111       goto unknown;
9112
9113     case 14: /* 1 tokens of length 14 */
9114       if (name[0] == 'g' &&
9115           name[1] == 'e' &&
9116           name[2] == 't' &&
9117           name[3] == 'p' &&
9118           name[4] == 'r' &&
9119           name[5] == 'o' &&
9120           name[6] == 't' &&
9121           name[7] == 'o' &&
9122           name[8] == 'b' &&
9123           name[9] == 'y' &&
9124           name[10] == 'n' &&
9125           name[11] == 'a' &&
9126           name[12] == 'm' &&
9127           name[13] == 'e')
9128       {                                           /* getprotobyname */
9129         return -KEY_getprotobyname;
9130       }
9131
9132       goto unknown;
9133
9134     case 16: /* 1 tokens of length 16 */
9135       if (name[0] == 'g' &&
9136           name[1] == 'e' &&
9137           name[2] == 't' &&
9138           name[3] == 'p' &&
9139           name[4] == 'r' &&
9140           name[5] == 'o' &&
9141           name[6] == 't' &&
9142           name[7] == 'o' &&
9143           name[8] == 'b' &&
9144           name[9] == 'y' &&
9145           name[10] == 'n' &&
9146           name[11] == 'u' &&
9147           name[12] == 'm' &&
9148           name[13] == 'b' &&
9149           name[14] == 'e' &&
9150           name[15] == 'r')
9151       {                                           /* getprotobynumber */
9152         return -KEY_getprotobynumber;
9153       }
9154
9155       goto unknown;
9156
9157     default:
9158       goto unknown;
9159   }
9160
9161 unknown:
9162   return 0;
9163 }
9164
9165 STATIC void
9166 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
9167 {
9168     const char *w;
9169
9170     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
9171         if (ckWARN(WARN_SYNTAX)) {
9172             int level = 1;
9173             for (w = s+2; *w && level; w++) {
9174                 if (*w == '(')
9175                     ++level;
9176                 else if (*w == ')')
9177                     --level;
9178             }
9179             if (*w)
9180                 for (; *w && isSPACE(*w); w++) ;
9181             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
9182                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9183                             "%s (...) interpreted as function",name);
9184         }
9185     }
9186     while (s < PL_bufend && isSPACE(*s))
9187         s++;
9188     if (*s == '(')
9189         s++;
9190     while (s < PL_bufend && isSPACE(*s))
9191         s++;
9192     if (isIDFIRST_lazy_if(s,UTF)) {
9193         w = s++;
9194         while (isALNUM_lazy_if(s,UTF))
9195             s++;
9196         while (s < PL_bufend && isSPACE(*s))
9197             s++;
9198         if (*s == ',') {
9199             I32 kw;
9200             *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9201             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9202             *s = ',';
9203             if (kw)
9204                 return;
9205             Perl_croak(aTHX_ "No comma allowed after %s", what);
9206         }
9207     }
9208 }
9209
9210 /* Either returns sv, or mortalizes sv and returns a new SV*.
9211    Best used as sv=new_constant(..., sv, ...).
9212    If s, pv are NULL, calls subroutine with one argument,
9213    and type is used with error messages only. */
9214
9215 STATIC SV *
9216 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9217                const char *type)
9218 {
9219     dVAR; dSP;
9220     HV * const table = GvHV(PL_hintgv);          /* ^H */
9221     SV *res;
9222     SV **cvp;
9223     SV *cv, *typesv;
9224     const char *why1 = "", *why2 = "", *why3 = "";
9225
9226     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9227         SV *msg;
9228
9229         why2 = strEQ(key,"charnames")
9230                ? "(possibly a missing \"use charnames ...\")"
9231                : "";
9232         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9233                             (type ? type: "undef"), why2);
9234
9235         /* This is convoluted and evil ("goto considered harmful")
9236          * but I do not understand the intricacies of all the different
9237          * failure modes of %^H in here.  The goal here is to make
9238          * the most probable error message user-friendly. --jhi */
9239
9240         goto msgdone;
9241
9242     report:
9243         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9244                             (type ? type: "undef"), why1, why2, why3);
9245     msgdone:
9246         yyerror(SvPVX_const(msg));
9247         SvREFCNT_dec(msg);
9248         return sv;
9249     }
9250     cvp = hv_fetch(table, key, strlen(key), FALSE);
9251     if (!cvp || !SvOK(*cvp)) {
9252         why1 = "$^H{";
9253         why2 = key;
9254         why3 = "} is not defined";
9255         goto report;
9256     }
9257     sv_2mortal(sv);                     /* Parent created it permanently */
9258     cv = *cvp;
9259     if (!pv && s)
9260         pv = sv_2mortal(newSVpvn(s, len));
9261     if (type && pv)
9262         typesv = sv_2mortal(newSVpv(type, 0));
9263     else
9264         typesv = &PL_sv_undef;
9265
9266     PUSHSTACKi(PERLSI_OVERLOAD);
9267     ENTER ;
9268     SAVETMPS;
9269
9270     PUSHMARK(SP) ;
9271     EXTEND(sp, 3);
9272     if (pv)
9273         PUSHs(pv);
9274     PUSHs(sv);
9275     if (pv)
9276         PUSHs(typesv);
9277     PUTBACK;
9278     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9279
9280     SPAGAIN ;
9281
9282     /* Check the eval first */
9283     if (!PL_in_eval && SvTRUE(ERRSV)) {
9284         sv_catpvs(ERRSV, "Propagated");
9285         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9286         (void)POPs;
9287         res = SvREFCNT_inc(sv);
9288     }
9289     else {
9290         res = POPs;
9291         (void)SvREFCNT_inc(res);
9292     }
9293
9294     PUTBACK ;
9295     FREETMPS ;
9296     LEAVE ;
9297     POPSTACK;
9298
9299     if (!SvOK(res)) {
9300         why1 = "Call to &{$^H{";
9301         why2 = key;
9302         why3 = "}} did not return a defined value";
9303         sv = res;
9304         goto report;
9305     }
9306
9307     return res;
9308 }
9309
9310 /* Returns a NUL terminated string, with the length of the string written to
9311    *slp
9312    */
9313 STATIC char *
9314 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9315 {
9316     register char *d = dest;
9317     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
9318     for (;;) {
9319         if (d >= e)
9320             Perl_croak(aTHX_ ident_too_long);
9321         if (isALNUM(*s))        /* UTF handled below */
9322             *d++ = *s++;
9323         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9324             *d++ = ':';
9325             *d++ = ':';
9326             s++;
9327         }
9328         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9329             *d++ = *s++;
9330             *d++ = *s++;
9331         }
9332         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9333             char *t = s + UTF8SKIP(s);
9334             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9335                 t += UTF8SKIP(t);
9336             if (d + (t - s) > e)
9337                 Perl_croak(aTHX_ ident_too_long);
9338             Copy(s, d, t - s, char);
9339             d += t - s;
9340             s = t;
9341         }
9342         else {
9343             *d = '\0';
9344             *slp = d - dest;
9345             return s;
9346         }
9347     }
9348 }
9349
9350 STATIC char *
9351 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9352 {
9353     register char *d;
9354     register char *e;
9355     char *bracket = Nullch;
9356     char funny = *s++;
9357
9358     if (isSPACE(*s))
9359         s = skipspace(s);
9360     d = dest;
9361     e = d + destlen - 3;        /* two-character token, ending NUL */
9362     if (isDIGIT(*s)) {
9363         while (isDIGIT(*s)) {
9364             if (d >= e)
9365                 Perl_croak(aTHX_ ident_too_long);
9366             *d++ = *s++;
9367         }
9368     }
9369     else {
9370         for (;;) {
9371             if (d >= e)
9372                 Perl_croak(aTHX_ ident_too_long);
9373             if (isALNUM(*s))    /* UTF handled below */
9374                 *d++ = *s++;
9375             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9376                 *d++ = ':';
9377                 *d++ = ':';
9378                 s++;
9379             }
9380             else if (*s == ':' && s[1] == ':') {
9381                 *d++ = *s++;
9382                 *d++ = *s++;
9383             }
9384             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9385                 char *t = s + UTF8SKIP(s);
9386                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9387                     t += UTF8SKIP(t);
9388                 if (d + (t - s) > e)
9389                     Perl_croak(aTHX_ ident_too_long);
9390                 Copy(s, d, t - s, char);
9391                 d += t - s;
9392                 s = t;
9393             }
9394             else
9395                 break;
9396         }
9397     }
9398     *d = '\0';
9399     d = dest;
9400     if (*d) {
9401         if (PL_lex_state != LEX_NORMAL)
9402             PL_lex_state = LEX_INTERPENDMAYBE;
9403         return s;
9404     }
9405     if (*s == '$' && s[1] &&
9406         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9407     {
9408         return s;
9409     }
9410     if (*s == '{') {
9411         bracket = s;
9412         s++;
9413     }
9414     else if (ck_uni)
9415         check_uni();
9416     if (s < send)
9417         *d = *s++;
9418     d[1] = '\0';
9419     if (*d == '^' && *s && isCONTROLVAR(*s)) {
9420         *d = toCTRL(*s);
9421         s++;
9422     }
9423     if (bracket) {
9424         if (isSPACE(s[-1])) {
9425             while (s < send) {
9426                 const char ch = *s++;
9427                 if (!SPACE_OR_TAB(ch)) {
9428                     *d = ch;
9429                     break;
9430                 }
9431             }
9432         }
9433         if (isIDFIRST_lazy_if(d,UTF)) {
9434             d++;
9435             if (UTF) {
9436                 e = s;
9437                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9438                     e += UTF8SKIP(e);
9439                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9440                         e += UTF8SKIP(e);
9441                 }
9442                 Copy(s, d, e - s, char);
9443                 d += e - s;
9444                 s = e;
9445             }
9446             else {
9447                 while ((isALNUM(*s) || *s == ':') && d < e)
9448                     *d++ = *s++;
9449                 if (d >= e)
9450                     Perl_croak(aTHX_ ident_too_long);
9451             }
9452             *d = '\0';
9453             while (s < send && SPACE_OR_TAB(*s)) s++;
9454             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9455                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9456                     const char *brack = *s == '[' ? "[...]" : "{...}";
9457                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9458                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9459                         funny, dest, brack, funny, dest, brack);
9460                 }
9461                 bracket++;
9462                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9463                 return s;
9464             }
9465         }
9466         /* Handle extended ${^Foo} variables
9467          * 1999-02-27 mjd-perl-patch@plover.com */
9468         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9469                  && isALNUM(*s))
9470         {
9471             d++;
9472             while (isALNUM(*s) && d < e) {
9473                 *d++ = *s++;
9474             }
9475             if (d >= e)
9476                 Perl_croak(aTHX_ ident_too_long);
9477             *d = '\0';
9478         }
9479         if (*s == '}') {
9480             s++;
9481             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9482                 PL_lex_state = LEX_INTERPEND;
9483                 PL_expect = XREF;
9484             }
9485             if (funny == '#')
9486                 funny = '@';
9487             if (PL_lex_state == LEX_NORMAL) {
9488                 if (ckWARN(WARN_AMBIGUOUS) &&
9489                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9490                 {
9491                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9492                         "Ambiguous use of %c{%s} resolved to %c%s",
9493                         funny, dest, funny, dest);
9494                 }
9495             }
9496         }
9497         else {
9498             s = bracket;                /* let the parser handle it */
9499             *dest = '\0';
9500         }
9501     }
9502     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9503         PL_lex_state = LEX_INTERPEND;
9504     return s;
9505 }
9506
9507 void
9508 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9509 {
9510     if (ch == 'i')
9511         *pmfl |= PMf_FOLD;
9512     else if (ch == 'g')
9513         *pmfl |= PMf_GLOBAL;
9514     else if (ch == 'c')
9515         *pmfl |= PMf_CONTINUE;
9516     else if (ch == 'o')
9517         *pmfl |= PMf_KEEP;
9518     else if (ch == 'm')
9519         *pmfl |= PMf_MULTILINE;
9520     else if (ch == 's')
9521         *pmfl |= PMf_SINGLELINE;
9522     else if (ch == 'x')
9523         *pmfl |= PMf_EXTENDED;
9524 }
9525
9526 STATIC char *
9527 S_scan_pat(pTHX_ char *start, I32 type)
9528 {
9529     PMOP *pm;
9530     char *s = scan_str(start,FALSE,FALSE);
9531
9532     if (!s) {
9533         char * const delimiter = skipspace(start);
9534         Perl_croak(aTHX_ *delimiter == '?'
9535                    ? "Search pattern not terminated or ternary operator parsed as search pattern"
9536                    : "Search pattern not terminated" );
9537     }
9538
9539     pm = (PMOP*)newPMOP(type, 0);
9540     if (PL_multi_open == '?')
9541         pm->op_pmflags |= PMf_ONCE;
9542     if(type == OP_QR) {
9543         while (*s && strchr("iomsx", *s))
9544             pmflag(&pm->op_pmflags,*s++);
9545     }
9546     else {
9547         while (*s && strchr("iogcmsx", *s))
9548             pmflag(&pm->op_pmflags,*s++);
9549     }
9550     /* issue a warning if /c is specified,but /g is not */
9551     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9552             && ckWARN(WARN_REGEXP))
9553     {
9554         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9555     }
9556
9557     pm->op_pmpermflags = pm->op_pmflags;
9558
9559     PL_lex_op = (OP*)pm;
9560     yylval.ival = OP_MATCH;
9561     return s;
9562 }
9563
9564 STATIC char *
9565 S_scan_subst(pTHX_ char *start)
9566 {
9567     dVAR;
9568     register char *s;
9569     register PMOP *pm;
9570     I32 first_start;
9571     I32 es = 0;
9572
9573     yylval.ival = OP_NULL;
9574
9575     s = scan_str(start,FALSE,FALSE);
9576
9577     if (!s)
9578         Perl_croak(aTHX_ "Substitution pattern not terminated");
9579
9580     if (s[-1] == PL_multi_open)
9581         s--;
9582
9583     first_start = PL_multi_start;
9584     s = scan_str(s,FALSE,FALSE);
9585     if (!s) {
9586         if (PL_lex_stuff) {
9587             SvREFCNT_dec(PL_lex_stuff);
9588             PL_lex_stuff = Nullsv;
9589         }
9590         Perl_croak(aTHX_ "Substitution replacement not terminated");
9591     }
9592     PL_multi_start = first_start;       /* so whole substitution is taken together */
9593
9594     pm = (PMOP*)newPMOP(OP_SUBST, 0);
9595     while (*s) {
9596         if (*s == 'e') {
9597             s++;
9598             es++;
9599         }
9600         else if (strchr("iogcmsx", *s))
9601             pmflag(&pm->op_pmflags,*s++);
9602         else
9603             break;
9604     }
9605
9606     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9607         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9608     }
9609
9610     if (es) {
9611         SV *repl;
9612         PL_sublex_info.super_bufptr = s;
9613         PL_sublex_info.super_bufend = PL_bufend;
9614         PL_multi_end = 0;
9615         pm->op_pmflags |= PMf_EVAL;
9616         repl = newSVpvs("");
9617         while (es-- > 0)
9618             sv_catpv(repl, es ? "eval " : "do ");
9619         sv_catpvs(repl, "{ ");
9620         sv_catsv(repl, PL_lex_repl);
9621         sv_catpvs(repl, " }");
9622         SvEVALED_on(repl);
9623         SvREFCNT_dec(PL_lex_repl);
9624         PL_lex_repl = repl;
9625     }
9626
9627     pm->op_pmpermflags = pm->op_pmflags;
9628     PL_lex_op = (OP*)pm;
9629     yylval.ival = OP_SUBST;
9630     return s;
9631 }
9632
9633 STATIC char *
9634 S_scan_trans(pTHX_ char *start)
9635 {
9636     register char* s;
9637     OP *o;
9638     short *tbl;
9639     I32 squash;
9640     I32 del;
9641     I32 complement;
9642
9643     yylval.ival = OP_NULL;
9644
9645     s = scan_str(start,FALSE,FALSE);
9646     if (!s)
9647         Perl_croak(aTHX_ "Transliteration pattern not terminated");
9648     if (s[-1] == PL_multi_open)
9649         s--;
9650
9651     s = scan_str(s,FALSE,FALSE);
9652     if (!s) {
9653         if (PL_lex_stuff) {
9654             SvREFCNT_dec(PL_lex_stuff);
9655             PL_lex_stuff = Nullsv;
9656         }
9657         Perl_croak(aTHX_ "Transliteration replacement not terminated");
9658     }
9659
9660     complement = del = squash = 0;
9661     while (1) {
9662         switch (*s) {
9663         case 'c':
9664             complement = OPpTRANS_COMPLEMENT;
9665             break;
9666         case 'd':
9667             del = OPpTRANS_DELETE;
9668             break;
9669         case 's':
9670             squash = OPpTRANS_SQUASH;
9671             break;
9672         default:
9673             goto no_more;
9674         }
9675         s++;
9676     }
9677   no_more:
9678
9679     Newx(tbl, complement&&!del?258:256, short);
9680     o = newPVOP(OP_TRANS, 0, (char*)tbl);
9681     o->op_private &= ~OPpTRANS_ALL;
9682     o->op_private |= del|squash|complement|
9683       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9684       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
9685
9686     PL_lex_op = o;
9687     yylval.ival = OP_TRANS;
9688     return s;
9689 }
9690
9691 STATIC char *
9692 S_scan_heredoc(pTHX_ register char *s)
9693 {
9694     SV *herewas;
9695     I32 op_type = OP_SCALAR;
9696     I32 len;
9697     SV *tmpstr;
9698     char term;
9699     const char *found_newline;
9700     register char *d;
9701     register char *e;
9702     char *peek;
9703     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9704
9705     s += 2;
9706     d = PL_tokenbuf;
9707     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9708     if (!outer)
9709         *d++ = '\n';
9710     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9711     if (*peek == '`' || *peek == '\'' || *peek =='"') {
9712         s = peek;
9713         term = *s++;
9714         s = delimcpy(d, e, s, PL_bufend, term, &len);
9715         d += len;
9716         if (s < PL_bufend)
9717             s++;
9718     }
9719     else {
9720         if (*s == '\\')
9721             s++, term = '\'';
9722         else
9723             term = '"';
9724         if (!isALNUM_lazy_if(s,UTF))
9725             deprecate_old("bare << to mean <<\"\"");
9726         for (; isALNUM_lazy_if(s,UTF); s++) {
9727             if (d < e)
9728                 *d++ = *s;
9729         }
9730     }
9731     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9732         Perl_croak(aTHX_ "Delimiter for here document is too long");
9733     *d++ = '\n';
9734     *d = '\0';
9735     len = d - PL_tokenbuf;
9736 #ifndef PERL_STRICT_CR
9737     d = strchr(s, '\r');
9738     if (d) {
9739         char * const olds = s;
9740         s = d;
9741         while (s < PL_bufend) {
9742             if (*s == '\r') {
9743                 *d++ = '\n';
9744                 if (*++s == '\n')
9745                     s++;
9746             }
9747             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
9748                 *d++ = *s++;
9749                 s++;
9750             }
9751             else
9752                 *d++ = *s++;
9753         }
9754         *d = '\0';
9755         PL_bufend = d;
9756         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9757         s = olds;
9758     }
9759 #endif
9760     if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) {
9761         herewas = newSVpvn(s,PL_bufend-s);
9762     }
9763     else {
9764         s--;
9765         herewas = newSVpvn(s,found_newline-s);
9766     }
9767     s += SvCUR(herewas);
9768
9769     tmpstr = NEWSV(87,79);
9770     sv_upgrade(tmpstr, SVt_PVIV);
9771     if (term == '\'') {
9772         op_type = OP_CONST;
9773         SvIV_set(tmpstr, -1);
9774     }
9775     else if (term == '`') {
9776         op_type = OP_BACKTICK;
9777         SvIV_set(tmpstr, '\\');
9778     }
9779
9780     CLINE;
9781     PL_multi_start = CopLINE(PL_curcop);
9782     PL_multi_open = PL_multi_close = '<';
9783     term = *PL_tokenbuf;
9784     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9785         char *bufptr = PL_sublex_info.super_bufptr;
9786         char *bufend = PL_sublex_info.super_bufend;
9787         char * const olds = s - SvCUR(herewas);
9788         s = strchr(bufptr, '\n');
9789         if (!s)
9790             s = bufend;
9791         d = s;
9792         while (s < bufend &&
9793           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9794             if (*s++ == '\n')
9795                 CopLINE_inc(PL_curcop);
9796         }
9797         if (s >= bufend) {
9798             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9799             missingterm(PL_tokenbuf);
9800         }
9801         sv_setpvn(herewas,bufptr,d-bufptr+1);
9802         sv_setpvn(tmpstr,d+1,s-d);
9803         s += len - 1;
9804         sv_catpvn(herewas,s,bufend-s);
9805         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9806
9807         s = olds;
9808         goto retval;
9809     }
9810     else if (!outer) {
9811         d = s;
9812         while (s < PL_bufend &&
9813           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9814             if (*s++ == '\n')
9815                 CopLINE_inc(PL_curcop);
9816         }
9817         if (s >= PL_bufend) {
9818             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9819             missingterm(PL_tokenbuf);
9820         }
9821         sv_setpvn(tmpstr,d+1,s-d);
9822         s += len - 1;
9823         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9824
9825         sv_catpvn(herewas,s,PL_bufend-s);
9826         sv_setsv(PL_linestr,herewas);
9827         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9828         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9829         PL_last_lop = PL_last_uni = Nullch;
9830     }
9831     else
9832         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
9833     while (s >= PL_bufend) {    /* multiple line string? */
9834         if (!outer ||
9835          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9836             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9837             missingterm(PL_tokenbuf);
9838         }
9839         CopLINE_inc(PL_curcop);
9840         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9841         PL_last_lop = PL_last_uni = Nullch;
9842 #ifndef PERL_STRICT_CR
9843         if (PL_bufend - PL_linestart >= 2) {
9844             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9845                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9846             {
9847                 PL_bufend[-2] = '\n';
9848                 PL_bufend--;
9849                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9850             }
9851             else if (PL_bufend[-1] == '\r')
9852                 PL_bufend[-1] = '\n';
9853         }
9854         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9855             PL_bufend[-1] = '\n';
9856 #endif
9857         if (PERLDB_LINE && PL_curstash != PL_debstash) {
9858             SV *sv = NEWSV(88,0);
9859
9860             sv_upgrade(sv, SVt_PVMG);
9861             sv_setsv(sv,PL_linestr);
9862             (void)SvIOK_on(sv);
9863             SvIV_set(sv, 0);
9864             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9865         }
9866         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9867             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9868             *(SvPVX(PL_linestr) + off ) = ' ';
9869             sv_catsv(PL_linestr,herewas);
9870             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9871             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9872         }
9873         else {
9874             s = PL_bufend;
9875             sv_catsv(tmpstr,PL_linestr);
9876         }
9877     }
9878     s++;
9879 retval:
9880     PL_multi_end = CopLINE(PL_curcop);
9881     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9882         SvPV_shrink_to_cur(tmpstr);
9883     }
9884     SvREFCNT_dec(herewas);
9885     if (!IN_BYTES) {
9886         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9887             SvUTF8_on(tmpstr);
9888         else if (PL_encoding)
9889             sv_recode_to_utf8(tmpstr, PL_encoding);
9890     }
9891     PL_lex_stuff = tmpstr;
9892     yylval.ival = op_type;
9893     return s;
9894 }
9895
9896 /* scan_inputsymbol
9897    takes: current position in input buffer
9898    returns: new position in input buffer
9899    side-effects: yylval and lex_op are set.
9900
9901    This code handles:
9902
9903    <>           read from ARGV
9904    <FH>         read from filehandle
9905    <pkg::FH>    read from package qualified filehandle
9906    <pkg'FH>     read from package qualified filehandle
9907    <$fh>        read from filehandle in $fh
9908    <*.h>        filename glob
9909
9910 */
9911
9912 STATIC char *
9913 S_scan_inputsymbol(pTHX_ char *start)
9914 {
9915     register char *s = start;           /* current position in buffer */
9916     register char *d;
9917     const char *e;
9918     char *end;
9919     I32 len;
9920
9921     d = PL_tokenbuf;                    /* start of temp holding space */
9922     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
9923     end = strchr(s, '\n');
9924     if (!end)
9925         end = PL_bufend;
9926     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
9927
9928     /* die if we didn't have space for the contents of the <>,
9929        or if it didn't end, or if we see a newline
9930     */
9931
9932     if (len >= sizeof PL_tokenbuf)
9933         Perl_croak(aTHX_ "Excessively long <> operator");
9934     if (s >= end)
9935         Perl_croak(aTHX_ "Unterminated <> operator");
9936
9937     s++;
9938
9939     /* check for <$fh>
9940        Remember, only scalar variables are interpreted as filehandles by
9941        this code.  Anything more complex (e.g., <$fh{$num}>) will be
9942        treated as a glob() call.
9943        This code makes use of the fact that except for the $ at the front,
9944        a scalar variable and a filehandle look the same.
9945     */
9946     if (*d == '$' && d[1]) d++;
9947
9948     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9949     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9950         d++;
9951
9952     /* If we've tried to read what we allow filehandles to look like, and
9953        there's still text left, then it must be a glob() and not a getline.
9954        Use scan_str to pull out the stuff between the <> and treat it
9955        as nothing more than a string.
9956     */
9957
9958     if (d - PL_tokenbuf != len) {
9959         yylval.ival = OP_GLOB;
9960         set_csh();
9961         s = scan_str(start,FALSE,FALSE);
9962         if (!s)
9963            Perl_croak(aTHX_ "Glob not terminated");
9964         return s;
9965     }
9966     else {
9967         bool readline_overriden = FALSE;
9968         GV *gv_readline = Nullgv;
9969         GV **gvp;
9970         /* we're in a filehandle read situation */
9971         d = PL_tokenbuf;
9972
9973         /* turn <> into <ARGV> */
9974         if (!len)
9975             Copy("ARGV",d,5,char);
9976
9977         /* Check whether readline() is overriden */
9978         if (((gv_readline = gv_fetchpv("readline", 0, SVt_PVCV))
9979                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9980                 ||
9981                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9982                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9983                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9984             readline_overriden = TRUE;
9985
9986         /* if <$fh>, create the ops to turn the variable into a
9987            filehandle
9988         */
9989         if (*d == '$') {
9990             I32 tmp;
9991
9992             /* try to find it in the pad for this block, otherwise find
9993                add symbol table ops
9994             */
9995             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9996                 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9997                     HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9998                     HEK *stashname = HvNAME_HEK(stash);
9999                     SV *sym = sv_2mortal(newSVhek(stashname));
10000                     sv_catpvs(sym, "::");
10001                     sv_catpv(sym, d+1);
10002                     d = SvPVX(sym);
10003                     goto intro_sym;
10004                 }
10005                 else {
10006                     OP *o = newOP(OP_PADSV, 0);
10007                     o->op_targ = tmp;
10008                     PL_lex_op = readline_overriden
10009                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10010                                 append_elem(OP_LIST, o,
10011                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10012                         : (OP*)newUNOP(OP_READLINE, 0, o);
10013                 }
10014             }
10015             else {
10016                 GV *gv;
10017                 ++d;
10018 intro_sym:
10019                 gv = gv_fetchpv(d,
10020                                 (PL_in_eval
10021                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
10022                                  : GV_ADDMULTI),
10023                                 SVt_PV);
10024                 PL_lex_op = readline_overriden
10025                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10026                             append_elem(OP_LIST,
10027                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10028                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10029                     : (OP*)newUNOP(OP_READLINE, 0,
10030                             newUNOP(OP_RV2SV, 0,
10031                                 newGVOP(OP_GV, 0, gv)));
10032             }
10033             if (!readline_overriden)
10034                 PL_lex_op->op_flags |= OPf_SPECIAL;
10035             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
10036             yylval.ival = OP_NULL;
10037         }
10038
10039         /* If it's none of the above, it must be a literal filehandle
10040            (<Foo::BAR> or <FOO>) so build a simple readline OP */
10041         else {
10042             GV *gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
10043             PL_lex_op = readline_overriden
10044                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10045                         append_elem(OP_LIST,
10046                             newGVOP(OP_GV, 0, gv),
10047                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10048                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10049             yylval.ival = OP_NULL;
10050         }
10051     }
10052
10053     return s;
10054 }
10055
10056
10057 /* scan_str
10058    takes: start position in buffer
10059           keep_quoted preserve \ on the embedded delimiter(s)
10060           keep_delims preserve the delimiters around the string
10061    returns: position to continue reading from buffer
10062    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10063         updates the read buffer.
10064
10065    This subroutine pulls a string out of the input.  It is called for:
10066         q               single quotes           q(literal text)
10067         '               single quotes           'literal text'
10068         qq              double quotes           qq(interpolate $here please)
10069         "               double quotes           "interpolate $here please"
10070         qx              backticks               qx(/bin/ls -l)
10071         `               backticks               `/bin/ls -l`
10072         qw              quote words             @EXPORT_OK = qw( func() $spam )
10073         m//             regexp match            m/this/
10074         s///            regexp substitute       s/this/that/
10075         tr///           string transliterate    tr/this/that/
10076         y///            string transliterate    y/this/that/
10077         ($*@)           sub prototypes          sub foo ($)
10078         (stuff)         sub attr parameters     sub foo : attr(stuff)
10079         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
10080
10081    In most of these cases (all but <>, patterns and transliterate)
10082    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
10083    calls scan_str().  s/// makes yylex() call scan_subst() which calls
10084    scan_str().  tr/// and y/// make yylex() call scan_trans() which
10085    calls scan_str().
10086
10087    It skips whitespace before the string starts, and treats the first
10088    character as the delimiter.  If the delimiter is one of ([{< then
10089    the corresponding "close" character )]}> is used as the closing
10090    delimiter.  It allows quoting of delimiters, and if the string has
10091    balanced delimiters ([{<>}]) it allows nesting.
10092
10093    On success, the SV with the resulting string is put into lex_stuff or,
10094    if that is already non-NULL, into lex_repl. The second case occurs only
10095    when parsing the RHS of the special constructs s/// and tr/// (y///).
10096    For convenience, the terminating delimiter character is stuffed into
10097    SvIVX of the SV.
10098 */
10099
10100 STATIC char *
10101 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
10102 {
10103     SV *sv;                             /* scalar value: string */
10104     char *tmps;                         /* temp string, used for delimiter matching */
10105     register char *s = start;           /* current position in the buffer */
10106     register char term;                 /* terminating character */
10107     register char *to;                  /* current position in the sv's data */
10108     I32 brackets = 1;                   /* bracket nesting level */
10109     bool has_utf8 = FALSE;              /* is there any utf8 content? */
10110     I32 termcode;                       /* terminating char. code */
10111     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
10112     STRLEN termlen;                     /* length of terminating string */
10113     char *last = NULL;                  /* last position for nesting bracket */
10114
10115     /* skip space before the delimiter */
10116     if (isSPACE(*s))
10117         s = skipspace(s);
10118
10119     /* mark where we are, in case we need to report errors */
10120     CLINE;
10121
10122     /* after skipping whitespace, the next character is the terminator */
10123     term = *s;
10124     if (!UTF) {
10125         termcode = termstr[0] = term;
10126         termlen = 1;
10127     }
10128     else {
10129         termcode = utf8_to_uvchr((U8*)s, &termlen);
10130         Copy(s, termstr, termlen, U8);
10131         if (!UTF8_IS_INVARIANT(term))
10132             has_utf8 = TRUE;
10133     }
10134
10135     /* mark where we are */
10136     PL_multi_start = CopLINE(PL_curcop);
10137     PL_multi_open = term;
10138
10139     /* find corresponding closing delimiter */
10140     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10141         termcode = termstr[0] = term = tmps[5];
10142
10143     PL_multi_close = term;
10144
10145     /* create a new SV to hold the contents.  87 is leak category, I'm
10146        assuming.  79 is the SV's initial length.  What a random number. */
10147     sv = NEWSV(87,79);
10148     sv_upgrade(sv, SVt_PVIV);
10149     SvIV_set(sv, termcode);
10150     (void)SvPOK_only(sv);               /* validate pointer */
10151
10152     /* move past delimiter and try to read a complete string */
10153     if (keep_delims)
10154         sv_catpvn(sv, s, termlen);
10155     s += termlen;
10156     for (;;) {
10157         if (PL_encoding && !UTF) {
10158             bool cont = TRUE;
10159
10160             while (cont) {
10161                 int offset = s - SvPVX_const(PL_linestr);
10162                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10163                                            &offset, (char*)termstr, termlen);
10164                 const char *ns = SvPVX_const(PL_linestr) + offset;
10165                 char *svlast = SvEND(sv) - 1;
10166
10167                 for (; s < ns; s++) {
10168                     if (*s == '\n' && !PL_rsfp)
10169                         CopLINE_inc(PL_curcop);
10170                 }
10171                 if (!found)
10172                     goto read_more_line;
10173                 else {
10174                     /* handle quoted delimiters */
10175                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10176                         const char *t;
10177                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10178                             t--;
10179                         if ((svlast-1 - t) % 2) {
10180                             if (!keep_quoted) {
10181                                 *(svlast-1) = term;
10182                                 *svlast = '\0';
10183                                 SvCUR_set(sv, SvCUR(sv) - 1);
10184                             }
10185                             continue;
10186                         }
10187                     }
10188                     if (PL_multi_open == PL_multi_close) {
10189                         cont = FALSE;
10190                     }
10191                     else {
10192                         const char *t;
10193                         char *w;
10194                         if (!last)
10195                             last = SvPVX(sv);
10196                         for (t = w = last; t < svlast; w++, t++) {
10197                             /* At here, all closes are "was quoted" one,
10198                                so we don't check PL_multi_close. */
10199                             if (*t == '\\') {
10200                                 if (!keep_quoted && *(t+1) == PL_multi_open)
10201                                     t++;
10202                                 else
10203                                     *w++ = *t++;
10204                             }
10205                             else if (*t == PL_multi_open)
10206                                 brackets++;
10207
10208                             *w = *t;
10209                         }
10210                         if (w < t) {
10211                             *w++ = term;
10212                             *w = '\0';
10213                             SvCUR_set(sv, w - SvPVX_const(sv));
10214                         }
10215                         last = w;
10216                         if (--brackets <= 0)
10217                             cont = FALSE;
10218                     }
10219                 }
10220             }
10221             if (!keep_delims) {
10222                 SvCUR_set(sv, SvCUR(sv) - 1);
10223                 *SvEND(sv) = '\0';
10224             }
10225             break;
10226         }
10227
10228         /* extend sv if need be */
10229         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10230         /* set 'to' to the next character in the sv's string */
10231         to = SvPVX(sv)+SvCUR(sv);
10232
10233         /* if open delimiter is the close delimiter read unbridle */
10234         if (PL_multi_open == PL_multi_close) {
10235             for (; s < PL_bufend; s++,to++) {
10236                 /* embedded newlines increment the current line number */
10237                 if (*s == '\n' && !PL_rsfp)
10238                     CopLINE_inc(PL_curcop);
10239                 /* handle quoted delimiters */
10240                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10241                     if (!keep_quoted && s[1] == term)
10242                         s++;
10243                 /* any other quotes are simply copied straight through */
10244                     else
10245                         *to++ = *s++;
10246                 }
10247                 /* terminate when run out of buffer (the for() condition), or
10248                    have found the terminator */
10249                 else if (*s == term) {
10250                     if (termlen == 1)
10251                         break;
10252                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10253                         break;
10254                 }
10255                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10256                     has_utf8 = TRUE;
10257                 *to = *s;
10258             }
10259         }
10260
10261         /* if the terminator isn't the same as the start character (e.g.,
10262            matched brackets), we have to allow more in the quoting, and
10263            be prepared for nested brackets.
10264         */
10265         else {
10266             /* read until we run out of string, or we find the terminator */
10267             for (; s < PL_bufend; s++,to++) {
10268                 /* embedded newlines increment the line count */
10269                 if (*s == '\n' && !PL_rsfp)
10270                     CopLINE_inc(PL_curcop);
10271                 /* backslashes can escape the open or closing characters */
10272                 if (*s == '\\' && s+1 < PL_bufend) {
10273                     if (!keep_quoted &&
10274                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10275                         s++;
10276                     else
10277                         *to++ = *s++;
10278                 }
10279                 /* allow nested opens and closes */
10280                 else if (*s == PL_multi_close && --brackets <= 0)
10281                     break;
10282                 else if (*s == PL_multi_open)
10283                     brackets++;
10284                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10285                     has_utf8 = TRUE;
10286                 *to = *s;
10287             }
10288         }
10289         /* terminate the copied string and update the sv's end-of-string */
10290         *to = '\0';
10291         SvCUR_set(sv, to - SvPVX_const(sv));
10292
10293         /*
10294          * this next chunk reads more into the buffer if we're not done yet
10295          */
10296
10297         if (s < PL_bufend)
10298             break;              /* handle case where we are done yet :-) */
10299
10300 #ifndef PERL_STRICT_CR
10301         if (to - SvPVX_const(sv) >= 2) {
10302             if ((to[-2] == '\r' && to[-1] == '\n') ||
10303                 (to[-2] == '\n' && to[-1] == '\r'))
10304             {
10305                 to[-2] = '\n';
10306                 to--;
10307                 SvCUR_set(sv, to - SvPVX_const(sv));
10308             }
10309             else if (to[-1] == '\r')
10310                 to[-1] = '\n';
10311         }
10312         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10313             to[-1] = '\n';
10314 #endif
10315
10316      read_more_line:
10317         /* if we're out of file, or a read fails, bail and reset the current
10318            line marker so we can report where the unterminated string began
10319         */
10320         if (!PL_rsfp ||
10321          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10322             sv_free(sv);
10323             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10324             return Nullch;
10325         }
10326         /* we read a line, so increment our line counter */
10327         CopLINE_inc(PL_curcop);
10328
10329         /* update debugger info */
10330         if (PERLDB_LINE && PL_curstash != PL_debstash) {
10331             SV * const sv = NEWSV(88,0);
10332
10333             sv_upgrade(sv, SVt_PVMG);
10334             sv_setsv(sv,PL_linestr);
10335             (void)SvIOK_on(sv);
10336             SvIV_set(sv, 0);
10337             av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10338         }
10339
10340         /* having changed the buffer, we must update PL_bufend */
10341         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10342         PL_last_lop = PL_last_uni = Nullch;
10343     }
10344
10345     /* at this point, we have successfully read the delimited string */
10346
10347     if (!PL_encoding || UTF) {
10348         if (keep_delims)
10349             sv_catpvn(sv, s, termlen);
10350         s += termlen;
10351     }
10352     if (has_utf8 || PL_encoding)
10353         SvUTF8_on(sv);
10354
10355     PL_multi_end = CopLINE(PL_curcop);
10356
10357     /* if we allocated too much space, give some back */
10358     if (SvCUR(sv) + 5 < SvLEN(sv)) {
10359         SvLEN_set(sv, SvCUR(sv) + 1);
10360         SvPV_renew(sv, SvLEN(sv));
10361     }
10362
10363     /* decide whether this is the first or second quoted string we've read
10364        for this op
10365     */
10366
10367     if (PL_lex_stuff)
10368         PL_lex_repl = sv;
10369     else
10370         PL_lex_stuff = sv;
10371     return s;
10372 }
10373
10374 /*
10375   scan_num
10376   takes: pointer to position in buffer
10377   returns: pointer to new position in buffer
10378   side-effects: builds ops for the constant in yylval.op
10379
10380   Read a number in any of the formats that Perl accepts:
10381
10382   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
10383   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
10384   0b[01](_?[01])*
10385   0[0-7](_?[0-7])*
10386   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10387
10388   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10389   thing it reads.
10390
10391   If it reads a number without a decimal point or an exponent, it will
10392   try converting the number to an integer and see if it can do so
10393   without loss of precision.
10394 */
10395
10396 char *
10397 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10398 {
10399     register const char *s = start;     /* current position in buffer */
10400     register char *d;                   /* destination in temp buffer */
10401     register char *e;                   /* end of temp buffer */
10402     NV nv;                              /* number read, as a double */
10403     SV *sv = Nullsv;                    /* place to put the converted number */
10404     bool floatit;                       /* boolean: int or float? */
10405     const char *lastub = NULL;          /* position of last underbar */
10406     static char const number_too_long[] = "Number too long";
10407
10408     /* We use the first character to decide what type of number this is */
10409
10410     switch (*s) {
10411     default:
10412       Perl_croak(aTHX_ "panic: scan_num");
10413
10414     /* if it starts with a 0, it could be an octal number, a decimal in
10415        0.13 disguise, or a hexadecimal number, or a binary number. */
10416     case '0':
10417         {
10418           /* variables:
10419              u          holds the "number so far"
10420              shift      the power of 2 of the base
10421                         (hex == 4, octal == 3, binary == 1)
10422              overflowed was the number more than we can hold?
10423
10424              Shift is used when we add a digit.  It also serves as an "are
10425              we in octal/hex/binary?" indicator to disallow hex characters
10426              when in octal mode.
10427            */
10428             NV n = 0.0;
10429             UV u = 0;
10430             I32 shift;
10431             bool overflowed = FALSE;
10432             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
10433             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10434             static const char* const bases[5] =
10435               { "", "binary", "", "octal", "hexadecimal" };
10436             static const char* const Bases[5] =
10437               { "", "Binary", "", "Octal", "Hexadecimal" };
10438             static const char* const maxima[5] =
10439               { "",
10440                 "0b11111111111111111111111111111111",
10441                 "",
10442                 "037777777777",
10443                 "0xffffffff" };
10444             const char *base, *Base, *max;
10445
10446             /* check for hex */
10447             if (s[1] == 'x') {
10448                 shift = 4;
10449                 s += 2;
10450                 just_zero = FALSE;
10451             } else if (s[1] == 'b') {
10452                 shift = 1;
10453                 s += 2;
10454                 just_zero = FALSE;
10455             }
10456             /* check for a decimal in disguise */
10457             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10458                 goto decimal;
10459             /* so it must be octal */
10460             else {
10461                 shift = 3;
10462                 s++;
10463             }
10464
10465             if (*s == '_') {
10466                if (ckWARN(WARN_SYNTAX))
10467                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10468                                "Misplaced _ in number");
10469                lastub = s++;
10470             }
10471
10472             base = bases[shift];
10473             Base = Bases[shift];
10474             max  = maxima[shift];
10475
10476             /* read the rest of the number */
10477             for (;;) {
10478                 /* x is used in the overflow test,
10479                    b is the digit we're adding on. */
10480                 UV x, b;
10481
10482                 switch (*s) {
10483
10484                 /* if we don't mention it, we're done */
10485                 default:
10486                     goto out;
10487
10488                 /* _ are ignored -- but warned about if consecutive */
10489                 case '_':
10490                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10491                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10492                                     "Misplaced _ in number");
10493                     lastub = s++;
10494                     break;
10495
10496                 /* 8 and 9 are not octal */
10497                 case '8': case '9':
10498                     if (shift == 3)
10499                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10500                     /* FALL THROUGH */
10501
10502                 /* octal digits */
10503                 case '2': case '3': case '4':
10504                 case '5': case '6': case '7':
10505                     if (shift == 1)
10506                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10507                     /* FALL THROUGH */
10508
10509                 case '0': case '1':
10510                     b = *s++ & 15;              /* ASCII digit -> value of digit */
10511                     goto digit;
10512
10513                 /* hex digits */
10514                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10515                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10516                     /* make sure they said 0x */
10517                     if (shift != 4)
10518                         goto out;
10519                     b = (*s++ & 7) + 9;
10520
10521                     /* Prepare to put the digit we have onto the end
10522                        of the number so far.  We check for overflows.
10523                     */
10524
10525                   digit:
10526                     just_zero = FALSE;
10527                     if (!overflowed) {
10528                         x = u << shift; /* make room for the digit */
10529
10530                         if ((x >> shift) != u
10531                             && !(PL_hints & HINT_NEW_BINARY)) {
10532                             overflowed = TRUE;
10533                             n = (NV) u;
10534                             if (ckWARN_d(WARN_OVERFLOW))
10535                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10536                                             "Integer overflow in %s number",
10537                                             base);
10538                         } else
10539                             u = x | b;          /* add the digit to the end */
10540                     }
10541                     if (overflowed) {
10542                         n *= nvshift[shift];
10543                         /* If an NV has not enough bits in its
10544                          * mantissa to represent an UV this summing of
10545                          * small low-order numbers is a waste of time
10546                          * (because the NV cannot preserve the
10547                          * low-order bits anyway): we could just
10548                          * remember when did we overflow and in the
10549                          * end just multiply n by the right
10550                          * amount. */
10551                         n += (NV) b;
10552                     }
10553                     break;
10554                 }
10555             }
10556
10557           /* if we get here, we had success: make a scalar value from
10558              the number.
10559           */
10560           out:
10561
10562             /* final misplaced underbar check */
10563             if (s[-1] == '_') {
10564                 if (ckWARN(WARN_SYNTAX))
10565                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10566             }
10567
10568             sv = NEWSV(92,0);
10569             if (overflowed) {
10570                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10571                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10572                                 "%s number > %s non-portable",
10573                                 Base, max);
10574                 sv_setnv(sv, n);
10575             }
10576             else {
10577 #if UVSIZE > 4
10578                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10579                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10580                                 "%s number > %s non-portable",
10581                                 Base, max);
10582 #endif
10583                 sv_setuv(sv, u);
10584             }
10585             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10586                 sv = new_constant(start, s - start, "integer",
10587                                   sv, Nullsv, NULL);
10588             else if (PL_hints & HINT_NEW_BINARY)
10589                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10590         }
10591         break;
10592
10593     /*
10594       handle decimal numbers.
10595       we're also sent here when we read a 0 as the first digit
10596     */
10597     case '1': case '2': case '3': case '4': case '5':
10598     case '6': case '7': case '8': case '9': case '.':
10599       decimal:
10600         d = PL_tokenbuf;
10601         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10602         floatit = FALSE;
10603
10604         /* read next group of digits and _ and copy into d */
10605         while (isDIGIT(*s) || *s == '_') {
10606             /* skip underscores, checking for misplaced ones
10607                if -w is on
10608             */
10609             if (*s == '_') {
10610                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10611                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10612                                 "Misplaced _ in number");
10613                 lastub = s++;
10614             }
10615             else {
10616                 /* check for end of fixed-length buffer */
10617                 if (d >= e)
10618                     Perl_croak(aTHX_ number_too_long);
10619                 /* if we're ok, copy the character */
10620                 *d++ = *s++;
10621             }
10622         }
10623
10624         /* final misplaced underbar check */
10625         if (lastub && s == lastub + 1) {
10626             if (ckWARN(WARN_SYNTAX))
10627                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10628         }
10629
10630         /* read a decimal portion if there is one.  avoid
10631            3..5 being interpreted as the number 3. followed
10632            by .5
10633         */
10634         if (*s == '.' && s[1] != '.') {
10635             floatit = TRUE;
10636             *d++ = *s++;
10637
10638             if (*s == '_') {
10639                 if (ckWARN(WARN_SYNTAX))
10640                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10641                                 "Misplaced _ in number");
10642                 lastub = s;
10643             }
10644
10645             /* copy, ignoring underbars, until we run out of digits.
10646             */
10647             for (; isDIGIT(*s) || *s == '_'; s++) {
10648                 /* fixed length buffer check */
10649                 if (d >= e)
10650                     Perl_croak(aTHX_ number_too_long);
10651                 if (*s == '_') {
10652                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10653                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10654                                    "Misplaced _ in number");
10655                    lastub = s;
10656                 }
10657                 else
10658                     *d++ = *s;
10659             }
10660             /* fractional part ending in underbar? */
10661             if (s[-1] == '_') {
10662                 if (ckWARN(WARN_SYNTAX))
10663                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10664                                 "Misplaced _ in number");
10665             }
10666             if (*s == '.' && isDIGIT(s[1])) {
10667                 /* oops, it's really a v-string, but without the "v" */
10668                 s = start;
10669                 goto vstring;
10670             }
10671         }
10672
10673         /* read exponent part, if present */
10674         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10675             floatit = TRUE;
10676             s++;
10677
10678             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10679             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
10680
10681             /* stray preinitial _ */
10682             if (*s == '_') {
10683                 if (ckWARN(WARN_SYNTAX))
10684                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10685                                 "Misplaced _ in number");
10686                 lastub = s++;
10687             }
10688
10689             /* allow positive or negative exponent */
10690             if (*s == '+' || *s == '-')
10691                 *d++ = *s++;
10692
10693             /* stray initial _ */
10694             if (*s == '_') {
10695                 if (ckWARN(WARN_SYNTAX))
10696                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10697                                 "Misplaced _ in number");
10698                 lastub = s++;
10699             }
10700
10701             /* read digits of exponent */
10702             while (isDIGIT(*s) || *s == '_') {
10703                 if (isDIGIT(*s)) {
10704                     if (d >= e)
10705                         Perl_croak(aTHX_ number_too_long);
10706                     *d++ = *s++;
10707                 }
10708                 else {
10709                    if (((lastub && s == lastub + 1) ||
10710                         (!isDIGIT(s[1]) && s[1] != '_'))
10711                     && ckWARN(WARN_SYNTAX))
10712                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10713                                    "Misplaced _ in number");
10714                    lastub = s++;
10715                 }
10716             }
10717         }
10718
10719
10720         /* make an sv from the string */
10721         sv = NEWSV(92,0);
10722
10723         /*
10724            We try to do an integer conversion first if no characters
10725            indicating "float" have been found.
10726          */
10727
10728         if (!floatit) {
10729             UV uv;
10730             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10731
10732             if (flags == IS_NUMBER_IN_UV) {
10733               if (uv <= IV_MAX)
10734                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10735               else
10736                 sv_setuv(sv, uv);
10737             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10738               if (uv <= (UV) IV_MIN)
10739                 sv_setiv(sv, -(IV)uv);
10740               else
10741                 floatit = TRUE;
10742             } else
10743               floatit = TRUE;
10744         }
10745         if (floatit) {
10746             /* terminate the string */
10747             *d = '\0';
10748             nv = Atof(PL_tokenbuf);
10749             sv_setnv(sv, nv);
10750         }
10751
10752         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10753                        (PL_hints & HINT_NEW_INTEGER) )
10754             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10755                               (floatit ? "float" : "integer"),
10756                               sv, Nullsv, NULL);
10757         break;
10758
10759     /* if it starts with a v, it could be a v-string */
10760     case 'v':
10761 vstring:
10762                 sv = NEWSV(92,5); /* preallocate storage space */
10763                 s = scan_vstring(s,sv);
10764         break;
10765     }
10766
10767     /* make the op for the constant and return */
10768
10769     if (sv)
10770         lvalp->opval = newSVOP(OP_CONST, 0, sv);
10771     else
10772         lvalp->opval = Nullop;
10773
10774     return (char *)s;
10775 }
10776
10777 STATIC char *
10778 S_scan_formline(pTHX_ register char *s)
10779 {
10780     register char *eol;
10781     register char *t;
10782     SV *stuff = newSVpvs("");
10783     bool needargs = FALSE;
10784     bool eofmt = FALSE;
10785
10786     while (!needargs) {
10787         if (*s == '.') {
10788 #ifdef PERL_STRICT_CR
10789             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10790 #else
10791             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10792 #endif
10793             if (*t == '\n' || t == PL_bufend) {
10794                 eofmt = TRUE;
10795                 break;
10796             }
10797         }
10798         if (PL_in_eval && !PL_rsfp) {
10799             eol = (char *) memchr(s,'\n',PL_bufend-s);
10800             if (!eol++)
10801                 eol = PL_bufend;
10802         }
10803         else
10804             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10805         if (*s != '#') {
10806             for (t = s; t < eol; t++) {
10807                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10808                     needargs = FALSE;
10809                     goto enough;        /* ~~ must be first line in formline */
10810                 }
10811                 if (*t == '@' || *t == '^')
10812                     needargs = TRUE;
10813             }
10814             if (eol > s) {
10815                 sv_catpvn(stuff, s, eol-s);
10816 #ifndef PERL_STRICT_CR
10817                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10818                     char *end = SvPVX(stuff) + SvCUR(stuff);
10819                     end[-2] = '\n';
10820                     end[-1] = '\0';
10821                     SvCUR_set(stuff, SvCUR(stuff) - 1);
10822                 }
10823 #endif
10824             }
10825             else
10826               break;
10827         }
10828         s = (char*)eol;
10829         if (PL_rsfp) {
10830             s = filter_gets(PL_linestr, PL_rsfp, 0);
10831             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10832             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10833             PL_last_lop = PL_last_uni = Nullch;
10834             if (!s) {
10835                 s = PL_bufptr;
10836                 break;
10837             }
10838         }
10839         incline(s);
10840     }
10841   enough:
10842     if (SvCUR(stuff)) {
10843         PL_expect = XTERM;
10844         if (needargs) {
10845             PL_lex_state = LEX_NORMAL;
10846             PL_nextval[PL_nexttoke].ival = 0;
10847             force_next(',');
10848         }
10849         else
10850             PL_lex_state = LEX_FORMLINE;
10851         if (!IN_BYTES) {
10852             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10853                 SvUTF8_on(stuff);
10854             else if (PL_encoding)
10855                 sv_recode_to_utf8(stuff, PL_encoding);
10856         }
10857         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10858         force_next(THING);
10859         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10860         force_next(LSTOP);
10861     }
10862     else {
10863         SvREFCNT_dec(stuff);
10864         if (eofmt)
10865             PL_lex_formbrack = 0;
10866         PL_bufptr = s;
10867     }
10868     return s;
10869 }
10870
10871 STATIC void
10872 S_set_csh(pTHX)
10873 {
10874 #ifdef CSH
10875     if (!PL_cshlen)
10876         PL_cshlen = strlen(PL_cshname);
10877 #endif
10878 }
10879
10880 I32
10881 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10882 {
10883     const I32 oldsavestack_ix = PL_savestack_ix;
10884     CV* outsidecv = PL_compcv;
10885
10886     if (PL_compcv) {
10887         assert(SvTYPE(PL_compcv) == SVt_PVCV);
10888     }
10889     SAVEI32(PL_subline);
10890     save_item(PL_subname);
10891     SAVESPTR(PL_compcv);
10892
10893     PL_compcv = (CV*)NEWSV(1104,0);
10894     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10895     CvFLAGS(PL_compcv) |= flags;
10896
10897     PL_subline = CopLINE(PL_curcop);
10898     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10899     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10900     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10901
10902     return oldsavestack_ix;
10903 }
10904
10905 #ifdef __SC__
10906 #pragma segment Perl_yylex
10907 #endif
10908 int
10909 Perl_yywarn(pTHX_ const char *s)
10910 {
10911     PL_in_eval |= EVAL_WARNONLY;
10912     yyerror(s);
10913     PL_in_eval &= ~EVAL_WARNONLY;
10914     return 0;
10915 }
10916
10917 int
10918 Perl_yyerror(pTHX_ const char *s)
10919 {
10920     const char *where = NULL;
10921     const char *context = NULL;
10922     int contlen = -1;
10923     SV *msg;
10924
10925     if (!yychar || (yychar == ';' && !PL_rsfp))
10926         where = "at EOF";
10927     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10928       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10929       PL_oldbufptr != PL_bufptr) {
10930         /*
10931                 Only for NetWare:
10932                 The code below is removed for NetWare because it abends/crashes on NetWare
10933                 when the script has error such as not having the closing quotes like:
10934                     if ($var eq "value)
10935                 Checking of white spaces is anyway done in NetWare code.
10936         */
10937 #ifndef NETWARE
10938         while (isSPACE(*PL_oldoldbufptr))
10939             PL_oldoldbufptr++;
10940 #endif
10941         context = PL_oldoldbufptr;
10942         contlen = PL_bufptr - PL_oldoldbufptr;
10943     }
10944     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10945       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10946         /*
10947                 Only for NetWare:
10948                 The code below is removed for NetWare because it abends/crashes on NetWare
10949                 when the script has error such as not having the closing quotes like:
10950                     if ($var eq "value)
10951                 Checking of white spaces is anyway done in NetWare code.
10952         */
10953 #ifndef NETWARE
10954         while (isSPACE(*PL_oldbufptr))
10955             PL_oldbufptr++;
10956 #endif
10957         context = PL_oldbufptr;
10958         contlen = PL_bufptr - PL_oldbufptr;
10959     }
10960     else if (yychar > 255)
10961         where = "next token ???";
10962     else if (yychar == -2) { /* YYEMPTY */
10963         if (PL_lex_state == LEX_NORMAL ||
10964            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10965             where = "at end of line";
10966         else if (PL_lex_inpat)
10967             where = "within pattern";
10968         else
10969             where = "within string";
10970     }
10971     else {
10972         SV *where_sv = sv_2mortal(newSVpvs("next char "));
10973         if (yychar < 32)
10974             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10975         else if (isPRINT_LC(yychar))
10976             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10977         else
10978             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10979         where = SvPVX_const(where_sv);
10980     }
10981     msg = sv_2mortal(newSVpv(s, 0));
10982     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10983         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10984     if (context)
10985         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10986     else
10987         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10988     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10989         Perl_sv_catpvf(aTHX_ msg,
10990         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10991                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10992         PL_multi_end = 0;
10993     }
10994     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10995         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10996     else
10997         qerror(msg);
10998     if (PL_error_count >= 10) {
10999         if (PL_in_eval && SvCUR(ERRSV))
11000             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11001             ERRSV, OutCopFILE(PL_curcop));
11002         else
11003             Perl_croak(aTHX_ "%s has too many errors.\n",
11004             OutCopFILE(PL_curcop));
11005     }
11006     PL_in_my = 0;
11007     PL_in_my_stash = NULL;
11008     return 0;
11009 }
11010 #ifdef __SC__
11011 #pragma segment Main
11012 #endif
11013
11014 STATIC char*
11015 S_swallow_bom(pTHX_ U8 *s)
11016 {
11017     const STRLEN slen = SvCUR(PL_linestr);
11018     switch (s[0]) {
11019     case 0xFF:
11020         if (s[1] == 0xFE) {
11021             /* UTF-16 little-endian? (or UTF32-LE?) */
11022             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
11023                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
11024 #ifndef PERL_NO_UTF16_FILTER
11025             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
11026             s += 2;
11027         utf16le:
11028             if (PL_bufend > (char*)s) {
11029                 U8 *news;
11030                 I32 newlen;
11031
11032                 filter_add(utf16rev_textfilter, NULL);
11033                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
11034                 utf16_to_utf8_reversed(s, news,
11035                                        PL_bufend - (char*)s - 1,
11036                                        &newlen);
11037                 sv_setpvn(PL_linestr, (const char*)news, newlen);
11038                 Safefree(news);
11039                 SvUTF8_on(PL_linestr);
11040                 s = (U8*)SvPVX(PL_linestr);
11041                 PL_bufend = SvPVX(PL_linestr) + newlen;
11042             }
11043 #else
11044             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
11045 #endif
11046         }
11047         break;
11048     case 0xFE:
11049         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
11050 #ifndef PERL_NO_UTF16_FILTER
11051             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11052             s += 2;
11053         utf16be:
11054             if (PL_bufend > (char *)s) {
11055                 U8 *news;
11056                 I32 newlen;
11057
11058                 filter_add(utf16_textfilter, NULL);
11059                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
11060                 utf16_to_utf8(s, news,
11061                               PL_bufend - (char*)s,
11062                               &newlen);
11063                 sv_setpvn(PL_linestr, (const char*)news, newlen);
11064                 Safefree(news);
11065                 SvUTF8_on(PL_linestr);
11066                 s = (U8*)SvPVX(PL_linestr);
11067                 PL_bufend = SvPVX(PL_linestr) + newlen;
11068             }
11069 #else
11070             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
11071 #endif
11072         }
11073         break;
11074     case 0xEF:
11075         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11076             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11077             s += 3;                      /* UTF-8 */
11078         }
11079         break;
11080     case 0:
11081         if (slen > 3) {
11082              if (s[1] == 0) {
11083                   if (s[2] == 0xFE && s[3] == 0xFF) {
11084                        /* UTF-32 big-endian */
11085                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
11086                   }
11087              }
11088              else if (s[2] == 0 && s[3] != 0) {
11089                   /* Leading bytes
11090                    * 00 xx 00 xx
11091                    * are a good indicator of UTF-16BE. */
11092                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11093                   goto utf16be;
11094              }
11095         }
11096     default:
11097          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11098                   /* Leading bytes
11099                    * xx 00 xx 00
11100                    * are a good indicator of UTF-16LE. */
11101               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11102               goto utf16le;
11103          }
11104     }
11105     return (char*)s;
11106 }
11107
11108 /*
11109  * restore_rsfp
11110  * Restore a source filter.
11111  */
11112
11113 static void
11114 restore_rsfp(pTHX_ void *f)
11115 {
11116     PerlIO * const fp = (PerlIO*)f;
11117
11118     if (PL_rsfp == PerlIO_stdin())
11119         PerlIO_clearerr(PL_rsfp);
11120     else if (PL_rsfp && (PL_rsfp != fp))
11121         PerlIO_close(PL_rsfp);
11122     PL_rsfp = fp;
11123 }
11124
11125 #ifndef PERL_NO_UTF16_FILTER
11126 static I32
11127 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11128 {
11129     const STRLEN old = SvCUR(sv);
11130     const I32 count = FILTER_READ(idx+1, sv, maxlen);
11131     DEBUG_P(PerlIO_printf(Perl_debug_log,
11132                           "utf16_textfilter(%p): %d %d (%d)\n",
11133                           utf16_textfilter, idx, maxlen, (int) count));
11134     if (count) {
11135         U8* tmps;
11136         I32 newlen;
11137         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11138         Copy(SvPVX_const(sv), tmps, old, char);
11139         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11140                       SvCUR(sv) - old, &newlen);
11141         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11142     }
11143     DEBUG_P({sv_dump(sv);});
11144     return SvCUR(sv);
11145 }
11146
11147 static I32
11148 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11149 {
11150     const STRLEN old = SvCUR(sv);
11151     const I32 count = FILTER_READ(idx+1, sv, maxlen);
11152     DEBUG_P(PerlIO_printf(Perl_debug_log,
11153                           "utf16rev_textfilter(%p): %d %d (%d)\n",
11154                           utf16rev_textfilter, idx, maxlen, (int) count));
11155     if (count) {
11156         U8* tmps;
11157         I32 newlen;
11158         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
11159         Copy(SvPVX_const(sv), tmps, old, char);
11160         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
11161                       SvCUR(sv) - old, &newlen);
11162         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
11163     }
11164     DEBUG_P({ sv_dump(sv); });
11165     return count;
11166 }
11167 #endif
11168
11169 /*
11170 Returns a pointer to the next character after the parsed
11171 vstring, as well as updating the passed in sv.
11172
11173 Function must be called like
11174
11175         sv = NEWSV(92,5);
11176         s = scan_vstring(s,sv);
11177
11178 The sv should already be large enough to store the vstring
11179 passed in, for performance reasons.
11180
11181 */
11182
11183 char *
11184 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11185 {
11186     const char *pos = s;
11187     const char *start = s;
11188     if (*pos == 'v') pos++;  /* get past 'v' */
11189     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11190         pos++;
11191     if ( *pos != '.') {
11192         /* this may not be a v-string if followed by => */
11193         const char *next = pos;
11194         while (next < PL_bufend && isSPACE(*next))
11195             ++next;
11196         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11197             /* return string not v-string */
11198             sv_setpvn(sv,(char *)s,pos-s);
11199             return (char *)pos;
11200         }
11201     }
11202
11203     if (!isALPHA(*pos)) {
11204         U8 tmpbuf[UTF8_MAXBYTES+1];
11205
11206         if (*s == 'v') s++;  /* get past 'v' */
11207
11208         sv_setpvn(sv, "", 0);
11209
11210         for (;;) {
11211             U8 *tmpend;
11212             UV rev = 0;
11213             {
11214                 /* this is atoi() that tolerates underscores */
11215                 const char *end = pos;
11216                 UV mult = 1;
11217                 while (--end >= s) {
11218                     UV orev;
11219                     if (*end == '_')
11220                         continue;
11221                     orev = rev;
11222                     rev += (*end - '0') * mult;
11223                     mult *= 10;
11224                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11225                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11226                                     "Integer overflow in decimal number");
11227                 }
11228             }
11229 #ifdef EBCDIC
11230             if (rev > 0x7FFFFFFF)
11231                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11232 #endif
11233             /* Append native character for the rev point */
11234             tmpend = uvchr_to_utf8(tmpbuf, rev);
11235             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11236             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11237                  SvUTF8_on(sv);
11238             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11239                  s = ++pos;
11240             else {
11241                  s = pos;
11242                  break;
11243             }
11244             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11245                  pos++;
11246         }
11247         SvPOK_on(sv);
11248         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11249         SvRMAGICAL_on(sv);
11250     }
11251     return (char *)s;
11252 }
11253
11254 /*
11255  * Local variables:
11256  * c-indentation-style: bsd
11257  * c-basic-offset: 4
11258  * indent-tabs-mode: t
11259  * End:
11260  *
11261  * ex: set ts=8 sts=4 sw=4 noet:
11262  */