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