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