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