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[] =
  30   "Identifier too long";
  31 static const char c_without_g[] =
  32   "Use of /c modifier is meaningless without /g";
  33 static const char c_in_subst[] =
  34   "Use of /c modifier is meaningless in s///";
  35
  36 static void restore_rsfp(pTHX_ void *f);
  37 #ifndef PERL_NO_UTF16_FILTER
  38 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  39 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  40 #endif
  41
  42 #define XFAKEBRACK 128
  43 #define XENUMMASK 127
  44
  45 #ifdef USE_UTF8_SCRIPTS
  46 #   define UTF (!IN_BYTES)
  47 #else
  48 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  49 #endif
  50
  51 /* In variables named $^X, these are the legal values for X.
  52  * 1999-02-27 mjd-perl-patch@plover.com */
  53 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  54
  55 /* On MacOS, respect nonbreaking spaces */
  56 #ifdef MACOS_TRADITIONAL
  57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  58 #else
  59 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  60 #endif
  61
  62 /* LEX_* are values for PL_lex_state, the state of the lexer.
  63  * They are arranged oddly so that the guard on the switch statement
  64  * can get by with a single comparison (if the compiler is smart enough).
  65  */
  66
  67 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  68
  69 #define LEX_NORMAL              10
  70 #define LEX_INTERPNORMAL         9
  71 #define LEX_INTERPCASEMOD        8
  72 #define LEX_INTERPPUSH           7
  73 #define LEX_INTERPSTART          6
  74 #define LEX_INTERPEND            5
  75 #define LEX_INTERPENDMAYBE       4
  76 #define LEX_INTERPCONCAT         3
  77 #define LEX_INTERPCONST          2
  78 #define LEX_FORMLINE             1
  79 #define LEX_KNOWNEXT             0
  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(s,(int)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_ const char* s, 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             else
 322                 Perl_sv_catpv(aTHX_ report, "(opval=null)");
 323             break;
 324         }
 325         Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
 326         if (s - PL_bufptr > 0)
 327             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
 328         else {
 329             if (PL_oldbufptr && *PL_oldbufptr)
 330                 sv_catpv(report, PL_tokenbuf);
 331         }
 332         PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
 333     };
 334     return (int)rv;
 335 }
 336
 337 #endif
 338
 339 /*
 340  * S_ao
 341  *
 342  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 343  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 344  */
 345
 346 STATIC int
 347 S_ao(pTHX_ int toketype)
 348 {
 349     if (*PL_bufptr == '=') {
 350         PL_bufptr++;
 351         if (toketype == ANDAND)
 352             yylval.ival = OP_ANDASSIGN;
 353         else if (toketype == OROR)
 354             yylval.ival = OP_ORASSIGN;
 355         else if (toketype == DORDOR)
 356             yylval.ival = OP_DORASSIGN;
 357         toketype = ASSIGNOP;
 358     }
 359     return toketype;
 360 }
 361
 362 /*
 363  * S_no_op
 364  * When Perl expects an operator and finds something else, no_op
 365  * prints the warning.  It always prints "<something> found where
 366  * operator expected.  It prints "Missing semicolon on previous line?"
 367  * if the surprise occurs at the start of the line.  "do you need to
 368  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 369  * where the compiler doesn't know if foo is a method call or a function.
 370  * It prints "Missing operator before end of line" if there's nothing
 371  * after the missing operator, or "... before <...>" if there is something
 372  * after the missing operator.
 373  */
 374
 375 STATIC void
 376 S_no_op(pTHX_ const char *what, char *s)
 377 {
 378     char * const oldbp = PL_bufptr;
 379     const bool is_first = (PL_oldbufptr == PL_linestart);
 380
 381     if (!s)
 382         s = oldbp;
 383     else
 384         PL_bufptr = s;
 385     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 386     if (ckWARN_d(WARN_SYNTAX)) {
 387         if (is_first)
 388             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 389                     "\t(Missing semicolon on previous line?)\n");
 390         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 391             const char *t;
 392             for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 393             if (t < PL_bufptr && isSPACE(*t))
 394                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 395                         "\t(Do you need to predeclare %.*s?)\n",
 396                     t - PL_oldoldbufptr, PL_oldoldbufptr);
 397         }
 398         else {
 399             assert(s >= oldbp);
 400             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 401                     "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 402         }
 403     }
 404     PL_bufptr = oldbp;
 405 }
 406
 407 /*
 408  * S_missingterm
 409  * Complain about missing quote/regexp/heredoc terminator.
 410  * If it's called with (char *)NULL then it cauterizes the line buffer.
 411  * If we're in a delimited string and the delimiter is a control
 412  * character, it's reformatted into a two-char sequence like ^C.
 413  * This is fatal.
 414  */
 415
 416 STATIC void
 417 S_missingterm(pTHX_ char *s)
 418 {
 419     char tmpbuf[3];
 420     char q;
 421     if (s) {
 422         char * const nl = strrchr(s,'\n');
 423         if (nl)
 424             *nl = '\0';
 425     }
 426     else if (
 427 #ifdef EBCDIC
 428         iscntrl(PL_multi_close)
 429 #else
 430         PL_multi_close < 32 || PL_multi_close == 127
 431 #endif
 432         ) {
 433         *tmpbuf = '^';
 434         tmpbuf[1] = toCTRL(PL_multi_close);
 435         tmpbuf[2] = '\0';
 436         s = tmpbuf;
 437     }
 438     else {
 439         *tmpbuf = (char)PL_multi_close;
 440         tmpbuf[1] = '\0';
 441         s = tmpbuf;
 442     }
 443     q = strchr(s,'"') ? '\'' : '"';
 444     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 445 }
 446
 447 /*
 448  * Perl_deprecate
 449  */
 450
 451 void
 452 Perl_deprecate(pTHX_ const char *s)
 453 {
 454     if (ckWARN(WARN_DEPRECATED))
 455         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 456 }
 457
 458 void
 459 Perl_deprecate_old(pTHX_ const char *s)
 460 {
 461     /* This function should NOT be called for any new deprecated warnings */
 462     /* Use Perl_deprecate instead                                         */
 463     /*                                                                    */
 464     /* It is here to maintain backward compatibility with the pre-5.8     */
 465     /* warnings category hierarchy. The "deprecated" category used to     */
 466     /* live under the "syntax" category. It is now a top-level category   */
 467     /* in its own right.                                                  */
 468
 469     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 470         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 471                         "Use of %s is deprecated", s);
 472 }
 473
 474 /*
 475  * depcom
 476  * Deprecate a comma-less variable list.
 477  */
 478
 479 STATIC void
 480 S_depcom(pTHX)
 481 {
 482     deprecate_old("comma-less variable list");
 483 }
 484
 485 /*
 486  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 487  * utf16-to-utf8-reversed.
 488  */
 489
 490 #ifdef PERL_CR_FILTER
 491 static void
 492 strip_return(SV *sv)
 493 {
 494     register const char *s = SvPVX_const(sv);
 495     register const char * const e = s + SvCUR(sv);
 496     /* outer loop optimized to do nothing if there are no CR-LFs */
 497     while (s < e) {
 498         if (*s++ == '\r' && *s == '\n') {
 499             /* hit a CR-LF, need to copy the rest */
 500             register char *d = s - 1;
 501             *d++ = *s++;
 502             while (s < e) {
 503                 if (*s == '\r' && s[1] == '\n')
 504                     s++;
 505                 *d++ = *s++;
 506             }
 507             SvCUR(sv) -= s - d;
 508             return;
 509         }
 510     }
 511 }
 512
 513 STATIC I32
 514 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 515 {
 516     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 517     if (count > 0 && !maxlen)
 518         strip_return(sv);
 519     return count;
 520 }
 521 #endif
 522
 523 /*
 524  * Perl_lex_start
 525  * Initialize variables.  Uses the Perl save_stack to save its state (for
 526  * recursive calls to the parser).
 527  */
 528
 529 void
 530 Perl_lex_start(pTHX_ SV *line)
 531 {
 532     const char *s;
 533     STRLEN len;
 534
 535     SAVEI32(PL_lex_dojoin);
 536     SAVEI32(PL_lex_brackets);
 537     SAVEI32(PL_lex_casemods);
 538     SAVEI32(PL_lex_starts);
 539     SAVEI32(PL_lex_state);
 540     SAVEVPTR(PL_lex_inpat);
 541     SAVEI32(PL_lex_inwhat);
 542     if (PL_lex_state == LEX_KNOWNEXT) {
 543         I32 toke = PL_nexttoke;
 544         while (--toke >= 0) {
 545             SAVEI32(PL_nexttype[toke]);
 546             SAVEVPTR(PL_nextval[toke]);
 547         }
 548         SAVEI32(PL_nexttoke);
 549     }
 550     SAVECOPLINE(PL_curcop);
 551     SAVEPPTR(PL_bufptr);
 552     SAVEPPTR(PL_bufend);
 553     SAVEPPTR(PL_oldbufptr);
 554     SAVEPPTR(PL_oldoldbufptr);
 555     SAVEPPTR(PL_last_lop);
 556     SAVEPPTR(PL_last_uni);
 557     SAVEPPTR(PL_linestart);
 558     SAVESPTR(PL_linestr);
 559     SAVEGENERICPV(PL_lex_brackstack);
 560     SAVEGENERICPV(PL_lex_casestack);
 561     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 562     SAVESPTR(PL_lex_stuff);
 563     SAVEI32(PL_lex_defer);
 564     SAVEI32(PL_sublex_info.sub_inwhat);
 565     SAVESPTR(PL_lex_repl);
 566     SAVEINT(PL_expect);
 567     SAVEINT(PL_lex_expect);
 568
 569     PL_lex_state = LEX_NORMAL;
 570     PL_lex_defer = 0;
 571     PL_expect = XSTATE;
 572     PL_lex_brackets = 0;
 573     Newx(PL_lex_brackstack, 120, char);
 574     Newx(PL_lex_casestack, 12, char);
 575     PL_lex_casemods = 0;
 576     *PL_lex_casestack = '\0';
 577     PL_lex_dojoin = 0;
 578     PL_lex_starts = 0;
 579     PL_lex_stuff = Nullsv;
 580     PL_lex_repl = Nullsv;
 581     PL_lex_inpat = 0;
 582     PL_nexttoke = 0;
 583     PL_lex_inwhat = 0;
 584     PL_sublex_info.sub_inwhat = 0;
 585     PL_linestr = line;
 586     if (SvREADONLY(PL_linestr))
 587         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 588     s = SvPV_const(PL_linestr, len);
 589     if (!len || s[len-1] != ';') {
 590         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 591             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 592         sv_catpvn(PL_linestr, "\n;", 2);
 593     }
 594     SvTEMP_off(PL_linestr);
 595     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 596     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 597     PL_last_lop = PL_last_uni = Nullch;
 598     PL_rsfp = 0;
 599 }
 600
 601 /*
 602  * Perl_lex_end
 603  * Finalizer for lexing operations.  Must be called when the parser is
 604  * done with the lexer.
 605  */
 606
 607 void
 608 Perl_lex_end(pTHX)
 609 {
 610     PL_doextract = FALSE;
 611 }
 612
 613 /*
 614  * S_incline
 615  * This subroutine has nothing to do with tilting, whether at windmills
 616  * or pinball tables.  Its name is short for "increment line".  It
 617  * increments the current line number in CopLINE(PL_curcop) and checks
 618  * to see whether the line starts with a comment of the form
 619  *    # line 500 "foo.pm"
 620  * If so, it sets the current line number and file to the values in the comment.
 621  */
 622
 623 STATIC void
 624 S_incline(pTHX_ char *s)
 625 {
 626     char *t;
 627     char *n;
 628     char *e;
 629     char ch;
 630
 631     CopLINE_inc(PL_curcop);
 632     if (*s++ != '#')
 633         return;
 634     while (SPACE_OR_TAB(*s)) s++;
 635     if (strnEQ(s, "line", 4))
 636         s += 4;
 637     else
 638         return;
 639     if (SPACE_OR_TAB(*s))
 640         s++;
 641     else
 642         return;
 643     while (SPACE_OR_TAB(*s)) s++;
 644     if (!isDIGIT(*s))
 645         return;
 646     n = s;
 647     while (isDIGIT(*s))
 648         s++;
 649     while (SPACE_OR_TAB(*s))
 650         s++;
 651     if (*s == '"' && (t = strchr(s+1, '"'))) {
 652         s++;
 653         e = t + 1;
 654     }
 655     else {
 656         for (t = s; !isSPACE(*t); t++) ;
 657         e = t;
 658     }
 659     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 660         e++;
 661     if (*e != '\n' && *e != '\0')
 662         return;         /* false alarm */
 663
 664     ch = *t;
 665     *t = '\0';
 666     if (t - s > 0) {
 667         CopFILE_free(PL_curcop);
 668         CopFILE_set(PL_curcop, s);
 669     }
 670     *t = ch;
 671     CopLINE_set(PL_curcop, atoi(n)-1);
 672 }
 673
 674 /*
 675  * S_skipspace
 676  * Called to gobble the appropriate amount and type of whitespace.
 677  * Skips comments as well.
 678  */
 679
 680 STATIC char *
 681 S_skipspace(pTHX_ register char *s)
 682 {
 683     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 684         while (s < PL_bufend && SPACE_OR_TAB(*s))
 685             s++;
 686         return s;
 687     }
 688     for (;;) {
 689         STRLEN prevlen;
 690         SSize_t oldprevlen, oldoldprevlen;
 691         SSize_t oldloplen = 0, oldunilen = 0;
 692         while (s < PL_bufend && isSPACE(*s)) {
 693             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 694                 incline(s);
 695         }
 696
 697         /* comment */
 698         if (s < PL_bufend && *s == '#') {
 699             while (s < PL_bufend && *s != '\n')
 700                 s++;
 701             if (s < PL_bufend) {
 702                 s++;
 703                 if (PL_in_eval && !PL_rsfp) {
 704                     incline(s);
 705                     continue;
 706                 }
 707             }
 708         }
 709
 710         /* only continue to recharge the buffer if we're at the end
 711          * of the buffer, we're not reading from a source filter, and
 712          * we're in normal lexing mode
 713          */
 714         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 715                 PL_lex_state == LEX_FORMLINE)
 716             return s;
 717
 718         /* try to recharge the buffer */
 719         if ((s = filter_gets(PL_linestr, PL_rsfp,
 720                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 721         {
 722             /* end of file.  Add on the -p or -n magic */
 723             if (PL_minus_p) {
 724                 sv_setpv(PL_linestr,
 725                          ";}continue{print or die qq(-p destination: $!\\n);}");
 726                 PL_minus_n = PL_minus_p = 0;
 727             }
 728             else if (PL_minus_n) {
 729                 sv_setpvn(PL_linestr, ";}", 2);
 730                 PL_minus_n = 0;
 731             }
 732             else
 733                 sv_setpvn(PL_linestr,";", 1);
 734
 735             /* reset variables for next time we lex */
 736             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 737                 = SvPVX(PL_linestr);
 738             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 739             PL_last_lop = PL_last_uni = Nullch;
 740
 741             /* Close the filehandle.  Could be from -P preprocessor,
 742              * STDIN, or a regular file.  If we were reading code from
 743              * STDIN (because the commandline held no -e or filename)
 744              * then we don't close it, we reset it so the code can
 745              * read from STDIN too.
 746              */
 747
 748             if (PL_preprocess && !PL_in_eval)
 749                 (void)PerlProc_pclose(PL_rsfp);
 750             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 751                 PerlIO_clearerr(PL_rsfp);
 752             else
 753                 (void)PerlIO_close(PL_rsfp);
 754             PL_rsfp = Nullfp;
 755             return s;
 756         }
 757
 758         /* not at end of file, so we only read another line */
 759         /* make corresponding updates to old pointers, for yyerror() */
 760         oldprevlen = PL_oldbufptr - PL_bufend;
 761         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 762         if (PL_last_uni)
 763             oldunilen = PL_last_uni - PL_bufend;
 764         if (PL_last_lop)
 765             oldloplen = PL_last_lop - PL_bufend;
 766         PL_linestart = PL_bufptr = s + prevlen;
 767         PL_bufend = s + SvCUR(PL_linestr);
 768         s = PL_bufptr;
 769         PL_oldbufptr = s + oldprevlen;
 770         PL_oldoldbufptr = s + oldoldprevlen;
 771         if (PL_last_uni)
 772             PL_last_uni = s + oldunilen;
 773         if (PL_last_lop)
 774             PL_last_lop = s + oldloplen;
 775         incline(s);
 776
 777         /* debugger active and we're not compiling the debugger code,
 778          * so store the line into the debugger's array of lines
 779          */
 780         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 781             SV * const sv = NEWSV(85,0);
 782
 783             sv_upgrade(sv, SVt_PVMG);
 784             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 785             (void)SvIOK_on(sv);
 786             SvIV_set(sv, 0);
 787             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 788         }
 789     }
 790 }
 791
 792 /*
 793  * S_check_uni
 794  * Check the unary operators to ensure there's no ambiguity in how they're
 795  * used.  An ambiguous piece of code would be:
 796  *     rand + 5
 797  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 798  * the +5 is its argument.
 799  */
 800
 801 STATIC void
 802 S_check_uni(pTHX)
 803 {
 804     char *s;
 805     char *t;
 806
 807     if (PL_oldoldbufptr != PL_last_uni)
 808         return;
 809     while (isSPACE(*PL_last_uni))
 810         PL_last_uni++;
 811     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 812     if ((t = strchr(s, '(')) && t < PL_bufptr)
 813         return;
 814     if (ckWARN_d(WARN_AMBIGUOUS)){
 815         const char ch = *s;
 816         *s = '\0';
 817         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
 818                    "Warning: Use of \"%s\" without parentheses is ambiguous",
 819                    PL_last_uni);
 820         *s = ch;
 821     }
 822 }
 823
 824 /*
 825  * LOP : macro to build a list operator.  Its behaviour has been replaced
 826  * with a subroutine, S_lop() for which LOP is just another name.
 827  */
 828
 829 #define LOP(f,x) return lop(f,x,s)
 830
 831 /*
 832  * S_lop
 833  * Build a list operator (or something that might be one).  The rules:
 834  *  - if we have a next token, then it's a list operator [why?]
 835  *  - if the next thing is an opening paren, then it's a function
 836  *  - else it's a list operator
 837  */
 838
 839 STATIC I32
 840 S_lop(pTHX_ I32 f, int x, char *s)
 841 {
 842     yylval.ival = f;
 843     CLINE;
 844     PL_expect = x;
 845     PL_bufptr = s;
 846     PL_last_lop = PL_oldbufptr;
 847     PL_last_lop_op = (OPCODE)f;
 848     if (PL_nexttoke)
 849         return REPORT(LSTOP);
 850     if (*s == '(')
 851         return REPORT(FUNC);
 852     s = skipspace(s);
 853     if (*s == '(')
 854         return REPORT(FUNC);
 855     else
 856         return REPORT(LSTOP);
 857 }
 858
 859 /*
 860  * S_force_next
 861  * When the lexer realizes it knows the next token (for instance,
 862  * it is reordering tokens for the parser) then it can call S_force_next
 863  * to know what token to return the next time the lexer is called.  Caller
 864  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 865  * handles the token correctly.
 866  */
 867
 868 STATIC void
 869 S_force_next(pTHX_ I32 type)
 870 {
 871     PL_nexttype[PL_nexttoke] = type;
 872     PL_nexttoke++;
 873     if (PL_lex_state != LEX_KNOWNEXT) {
 874         PL_lex_defer = PL_lex_state;
 875         PL_lex_expect = PL_expect;
 876         PL_lex_state = LEX_KNOWNEXT;
 877     }
 878 }
 879
 880 STATIC SV *
 881 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
 882 {
 883     SV * const sv = newSVpvn(start,len);
 884     if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
 885         SvUTF8_on(sv);
 886     return sv;
 887 }
 888
 889 /*
 890  * S_force_word
 891  * When the lexer knows the next thing is a word (for instance, it has
 892  * just seen -> and it knows that the next char is a word char, then
 893  * it calls S_force_word to stick the next word into the PL_next lookahead.
 894  *
 895  * Arguments:
 896  *   char *start : buffer position (must be within PL_linestr)
 897  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 898  *   int check_keyword : if true, Perl checks to make sure the word isn't
 899  *       a keyword (do this if the word is a label, e.g. goto FOO)
 900  *   int allow_pack : if true, : characters will also be allowed (require,
 901  *       use, etc. do this)
 902  *   int allow_initial_tick : used by the "sub" lexer only.
 903  */
 904
 905 STATIC char *
 906 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 907 {
 908     register char *s;
 909     STRLEN len;
 910
 911     start = skipspace(start);
 912     s = start;
 913     if (isIDFIRST_lazy_if(s,UTF) ||
 914         (allow_pack && *s == ':') ||
 915         (allow_initial_tick && *s == '\'') )
 916     {
 917         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 918         if (check_keyword && keyword(PL_tokenbuf, len))
 919             return start;
 920         if (token == METHOD) {
 921             s = skipspace(s);
 922             if (*s == '(')
 923                 PL_expect = XTERM;
 924             else {
 925                 PL_expect = XOPERATOR;
 926             }
 927         }
 928         PL_nextval[PL_nexttoke].opval
 929             = (OP*)newSVOP(OP_CONST,0,
 930                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
 931         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 932         force_next(token);
 933     }
 934     return s;
 935 }
 936
 937 /*
 938  * S_force_ident
 939  * Called when the lexer wants $foo *foo &foo etc, but the program
 940  * text only contains the "foo" portion.  The first argument is a pointer
 941  * to the "foo", and the second argument is the type symbol to prefix.
 942  * Forces the next token to be a "WORD".
 943  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 944  */
 945
 946 STATIC void
 947 S_force_ident(pTHX_ register const char *s, int kind)
 948 {
 949     if (s && *s) {
 950         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 951         PL_nextval[PL_nexttoke].opval = o;
 952         force_next(WORD);
 953         if (kind) {
 954             o->op_private = OPpCONST_ENTERED;
 955             /* XXX see note in pp_entereval() for why we forgo typo
 956                warnings if the symbol must be introduced in an eval.
 957                GSAR 96-10-12 */
 958             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 959                 kind == '$' ? SVt_PV :
 960                 kind == '@' ? SVt_PVAV :
 961                 kind == '%' ? SVt_PVHV :
 962                               SVt_PVGV
 963                 );
 964         }
 965     }
 966 }
 967
 968 NV
 969 Perl_str_to_version(pTHX_ SV *sv)
 970 {
 971     NV retval = 0.0;
 972     NV nshift = 1.0;
 973     STRLEN len;
 974     const char *start = SvPV_const(sv,len);
 975     const char * const end = start + len;
 976     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
 977     while (start < end) {
 978         STRLEN skip;
 979         UV n;
 980         if (utf)
 981             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
 982         else {
 983             n = *(U8*)start;
 984             skip = 1;
 985         }
 986         retval += ((NV)n)/nshift;
 987         start += skip;
 988         nshift *= 1000;
 989     }
 990     return retval;
 991 }
 992
 993 /*
 994  * S_force_version
 995  * Forces the next token to be a version number.
 996  * If the next token appears to be an invalid version number, (e.g. "v2b"),
 997  * and if "guessing" is TRUE, then no new token is created (and the caller
 998  * must use an alternative parsing method).
 999  */
1000
1001 STATIC char *
1002 S_force_version(pTHX_ char *s, int guessing)
1003 {
1004     OP *version = Nullop;
1005     char *d;
1006
1007     s = skipspace(s);
1008
1009     d = s;
1010     if (*d == 'v')
1011         d++;
1012     if (isDIGIT(*d)) {
1013         while (isDIGIT(*d) || *d == '_' || *d == '.')
1014             d++;
1015         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1016             SV *ver;
1017             s = scan_num(s, &yylval);
1018             version = yylval.opval;
1019             ver = cSVOPx(version)->op_sv;
1020             if (SvPOK(ver) && !SvNIOK(ver)) {
1021                 SvUPGRADE(ver, SVt_PVNV);
1022                 SvNV_set(ver, str_to_version(ver));
1023                 SvNOK_on(ver);          /* hint that it is a version */
1024             }
1025         }
1026         else if (guessing)
1027             return s;
1028     }
1029
1030     /* NOTE: The parser sees the package name and the VERSION swapped */
1031     PL_nextval[PL_nexttoke].opval = version;
1032     force_next(WORD);
1033
1034     return s;
1035 }
1036
1037 /*
1038  * S_tokeq
1039  * Tokenize a quoted string passed in as an SV.  It finds the next
1040  * chunk, up to end of string or a backslash.  It may make a new
1041  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1042  * turns \\ into \.
1043  */
1044
1045 STATIC SV *
1046 S_tokeq(pTHX_ SV *sv)
1047 {
1048     register char *s;
1049     register char *send;
1050     register char *d;
1051     STRLEN len = 0;
1052     SV *pv = sv;
1053
1054     if (!SvLEN(sv))
1055         goto finish;
1056
1057     s = SvPV_force(sv, len);
1058     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1059         goto finish;
1060     send = s + len;
1061     while (s < send && *s != '\\')
1062         s++;
1063     if (s == send)
1064         goto finish;
1065     d = s;
1066     if ( PL_hints & HINT_NEW_STRING ) {
1067         pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1068         if (SvUTF8(sv))
1069             SvUTF8_on(pv);
1070     }
1071     while (s < send) {
1072         if (*s == '\\') {
1073             if (s + 1 < send && (s[1] == '\\'))
1074                 s++;            /* all that, just for this */
1075         }
1076         *d++ = *s++;
1077     }
1078     *d = '\0';
1079     SvCUR_set(sv, d - SvPVX_const(sv));
1080   finish:
1081     if ( PL_hints & HINT_NEW_STRING )
1082        return new_constant(NULL, 0, "q", sv, pv, "q");
1083     return sv;
1084 }
1085
1086 /*
1087  * Now come three functions related to double-quote context,
1088  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1089  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1090  * interact with PL_lex_state, and create fake ( ... ) argument lists
1091  * to handle functions and concatenation.
1092  * They assume that whoever calls them will be setting up a fake
1093  * join call, because each subthing puts a ',' after it.  This lets
1094  *   "lower \luPpEr"
1095  * become
1096  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1097  *
1098  * (I'm not sure whether the spurious commas at the end of lcfirst's
1099  * arguments and join's arguments are created or not).
1100  */
1101
1102 /*
1103  * S_sublex_start
1104  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1105  *
1106  * Pattern matching will set PL_lex_op to the pattern-matching op to
1107  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1108  *
1109  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1110  *
1111  * Everything else becomes a FUNC.
1112  *
1113  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1114  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1115  * call to S_sublex_push().
1116  */
1117
1118 STATIC I32
1119 S_sublex_start(pTHX)
1120 {
1121     const register I32 op_type = yylval.ival;
1122
1123     if (op_type == OP_NULL) {
1124         yylval.opval = PL_lex_op;
1125         PL_lex_op = Nullop;
1126         return THING;
1127     }
1128     if (op_type == OP_CONST || op_type == OP_READLINE) {
1129         SV *sv = tokeq(PL_lex_stuff);
1130
1131         if (SvTYPE(sv) == SVt_PVIV) {
1132             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1133             STRLEN len;
1134             const char *p = SvPV_const(sv, len);
1135             SV * const nsv = newSVpvn(p, len);
1136             if (SvUTF8(sv))
1137                 SvUTF8_on(nsv);
1138             SvREFCNT_dec(sv);
1139             sv = nsv;
1140         }
1141         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1142         PL_lex_stuff = Nullsv;
1143         /* Allow <FH> // "foo" */
1144         if (op_type == OP_READLINE)
1145             PL_expect = XTERMORDORDOR;
1146         return THING;
1147     }
1148
1149     PL_sublex_info.super_state = PL_lex_state;
1150     PL_sublex_info.sub_inwhat = op_type;
1151     PL_sublex_info.sub_op = PL_lex_op;
1152     PL_lex_state = LEX_INTERPPUSH;
1153
1154     PL_expect = XTERM;
1155     if (PL_lex_op) {
1156         yylval.opval = PL_lex_op;
1157         PL_lex_op = Nullop;
1158         return PMFUNC;
1159     }
1160     else
1161         return FUNC;
1162 }
1163
1164 /*
1165  * S_sublex_push
1166  * Create a new scope to save the lexing state.  The scope will be
1167  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1168  * to the uc, lc, etc. found before.
1169  * Sets PL_lex_state to LEX_INTERPCONCAT.
1170  */
1171
1172 STATIC I32
1173 S_sublex_push(pTHX)
1174 {
1175     dVAR;
1176     ENTER;
1177
1178     PL_lex_state = PL_sublex_info.super_state;
1179     SAVEI32(PL_lex_dojoin);
1180     SAVEI32(PL_lex_brackets);
1181     SAVEI32(PL_lex_casemods);
1182     SAVEI32(PL_lex_starts);
1183     SAVEI32(PL_lex_state);
1184     SAVEVPTR(PL_lex_inpat);
1185     SAVEI32(PL_lex_inwhat);
1186     SAVECOPLINE(PL_curcop);
1187     SAVEPPTR(PL_bufptr);
1188     SAVEPPTR(PL_bufend);
1189     SAVEPPTR(PL_oldbufptr);
1190     SAVEPPTR(PL_oldoldbufptr);
1191     SAVEPPTR(PL_last_lop);
1192     SAVEPPTR(PL_last_uni);
1193     SAVEPPTR(PL_linestart);
1194     SAVESPTR(PL_linestr);
1195     SAVEGENERICPV(PL_lex_brackstack);
1196     SAVEGENERICPV(PL_lex_casestack);
1197
1198     PL_linestr = PL_lex_stuff;
1199     PL_lex_stuff = Nullsv;
1200
1201     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1202         = SvPVX(PL_linestr);
1203     PL_bufend += SvCUR(PL_linestr);
1204     PL_last_lop = PL_last_uni = Nullch;
1205     SAVEFREESV(PL_linestr);
1206
1207     PL_lex_dojoin = FALSE;
1208     PL_lex_brackets = 0;
1209     Newx(PL_lex_brackstack, 120, char);
1210     Newx(PL_lex_casestack, 12, char);
1211     PL_lex_casemods = 0;
1212     *PL_lex_casestack = '\0';
1213     PL_lex_starts = 0;
1214     PL_lex_state = LEX_INTERPCONCAT;
1215     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1216
1217     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1218     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1219         PL_lex_inpat = PL_sublex_info.sub_op;
1220     else
1221         PL_lex_inpat = Nullop;
1222
1223     return '(';
1224 }
1225
1226 /*
1227  * S_sublex_done
1228  * Restores lexer state after a S_sublex_push.
1229  */
1230
1231 STATIC I32
1232 S_sublex_done(pTHX)
1233 {
1234     dVAR;
1235     if (!PL_lex_starts++) {
1236         SV * const sv = newSVpvn("",0);
1237         if (SvUTF8(PL_linestr))
1238             SvUTF8_on(sv);
1239         PL_expect = XOPERATOR;
1240         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1241         return THING;
1242     }
1243
1244     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1245         PL_lex_state = LEX_INTERPCASEMOD;
1246         return yylex();
1247     }
1248
1249     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1250     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1251         PL_linestr = PL_lex_repl;
1252         PL_lex_inpat = 0;
1253         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1254         PL_bufend += SvCUR(PL_linestr);
1255         PL_last_lop = PL_last_uni = Nullch;
1256         SAVEFREESV(PL_linestr);
1257         PL_lex_dojoin = FALSE;
1258         PL_lex_brackets = 0;
1259         PL_lex_casemods = 0;
1260         *PL_lex_casestack = '\0';
1261         PL_lex_starts = 0;
1262         if (SvEVALED(PL_lex_repl)) {
1263             PL_lex_state = LEX_INTERPNORMAL;
1264             PL_lex_starts++;
1265             /*  we don't clear PL_lex_repl here, so that we can check later
1266                 whether this is an evalled subst; that means we rely on the
1267                 logic to ensure sublex_done() is called again only via the
1268                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1269         }
1270         else {
1271             PL_lex_state = LEX_INTERPCONCAT;
1272             PL_lex_repl = Nullsv;
1273         }
1274         return ',';
1275     }
1276     else {
1277         LEAVE;
1278         PL_bufend = SvPVX(PL_linestr);
1279         PL_bufend += SvCUR(PL_linestr);
1280         PL_expect = XOPERATOR;
1281         PL_sublex_info.sub_inwhat = 0;
1282         return ')';
1283     }
1284 }
1285
1286 /*
1287   scan_const
1288
1289   Extracts a pattern, double-quoted string, or transliteration.  This
1290   is terrifying code.
1291
1292   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1293   processing a pattern (PL_lex_inpat is true), a transliteration
1294   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1295
1296   Returns a pointer to the character scanned up to. Iff this is
1297   advanced from the start pointer supplied (ie if anything was
1298   successfully parsed), will leave an OP for the substring scanned
1299   in yylval. Caller must intuit reason for not parsing further
1300   by looking at the next characters herself.
1301
1302   In patterns:
1303     backslashes:
1304       double-quoted style: \r and \n
1305       regexp special ones: \D \s
1306       constants: \x3
1307       backrefs: \1 (deprecated in substitution replacements)
1308       case and quoting: \U \Q \E
1309     stops on @ and $, but not for $ as tail anchor
1310
1311   In transliterations:
1312     characters are VERY literal, except for - not at the start or end
1313     of the string, which indicates a range.  scan_const expands the
1314     range to the full set of intermediate characters.
1315
1316   In double-quoted strings:
1317     backslashes:
1318       double-quoted style: \r and \n
1319       constants: \x3
1320       backrefs: \1 (deprecated)
1321       case and quoting: \U \Q \E
1322     stops on @ and $
1323
1324   scan_const does *not* construct ops to handle interpolated strings.
1325   It stops processing as soon as it finds an embedded $ or @ variable
1326   and leaves it to the caller to work out what's going on.
1327
1328   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1329
1330   $ in pattern could be $foo or could be tail anchor.  Assumption:
1331   it's a tail anchor if $ is the last thing in the string, or if it's
1332   followed by one of ")| \n\t"
1333
1334   \1 (backreferences) are turned into $1
1335
1336   The structure of the code is
1337       while (there's a character to process) {
1338           handle transliteration ranges
1339           skip regexp comments
1340           skip # initiated comments in //x patterns
1341           check for embedded @foo
1342           check for embedded scalars
1343           if (backslash) {
1344               leave intact backslashes from leave (below)
1345               deprecate \1 in strings and sub replacements
1346               handle string-changing backslashes \l \U \Q \E, etc.
1347               switch (what was escaped) {
1348                   handle - in a transliteration (becomes a literal -)
1349                   handle \132 octal characters
1350                   handle 0x15 hex characters
1351                   handle \cV (control V)
1352                   handle printf backslashes (\f, \r, \n, etc)
1353               } (end switch)
1354           } (end if backslash)
1355     } (end while character to read)
1356
1357 */
1358
1359 STATIC char *
1360 S_scan_const(pTHX_ char *start)
1361 {
1362     register char *send = PL_bufend;            /* end of the constant */
1363     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1364     register char *s = start;                   /* start of the constant */
1365     register char *d = SvPVX(sv);               /* destination for copies */
1366     bool dorange = FALSE;                       /* are we in a translit range? */
1367     bool didrange = FALSE;                      /* did we just finish a range? */
1368     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1369     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1370     UV uv;
1371 #ifdef EBCDIC
1372     UV literal_endpoint = 0;
1373 #endif
1374
1375     const char *leaveit =       /* set of acceptably-backslashed characters */
1376         PL_lex_inpat
1377             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1378             : "";
1379
1380     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1381         /* If we are doing a trans and we know we want UTF8 set expectation */
1382         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1383         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1384     }
1385
1386
1387     while (s < send || dorange) {
1388         /* get transliterations out of the way (they're most literal) */
1389         if (PL_lex_inwhat == OP_TRANS) {
1390             /* expand a range A-Z to the full set of characters.  AIE! */
1391             if (dorange) {
1392                 I32 i;                          /* current expanded character */
1393                 I32 min;                        /* first character in range */
1394                 I32 max;                        /* last character in range */
1395
1396                 if (has_utf8) {
1397                     char * const c = (char*)utf8_hop((U8*)d, -1);
1398                     char *e = d++;
1399                     while (e-- > c)
1400                         *(e + 1) = *e;
1401                     *c = (char)UTF_TO_NATIVE(0xff);
1402                     /* mark the range as done, and continue */
1403                     dorange = FALSE;
1404                     didrange = TRUE;
1405                     continue;
1406                 }
1407
1408                 i = d - SvPVX_const(sv);                /* remember current offset */
1409                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1410                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1411                 d -= 2;                         /* eat the first char and the - */
1412
1413                 min = (U8)*d;                   /* first char in range */
1414                 max = (U8)d[1];                 /* last char in range  */
1415
1416                 if (min > max) {
1417                     Perl_croak(aTHX_
1418                                "Invalid range \"%c-%c\" in transliteration operator",
1419                                (char)min, (char)max);
1420                 }
1421
1422 #ifdef EBCDIC
1423                 if (literal_endpoint == 2 &&
1424                     ((isLOWER(min) && isLOWER(max)) ||
1425                      (isUPPER(min) && isUPPER(max)))) {
1426                     if (isLOWER(min)) {
1427                         for (i = min; i <= max; i++)
1428                             if (isLOWER(i))
1429                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1430                     } else {
1431                         for (i = min; i <= max; i++)
1432                             if (isUPPER(i))
1433                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1434                     }
1435                 }
1436                 else
1437 #endif
1438                     for (i = min; i <= max; i++)
1439                         *d++ = (char)i;
1440
1441                 /* mark the range as done, and continue */
1442                 dorange = FALSE;
1443                 didrange = TRUE;
1444 #ifdef EBCDIC
1445                 literal_endpoint = 0;
1446 #endif
1447                 continue;
1448             }
1449
1450             /* range begins (ignore - as first or last char) */
1451             else if (*s == '-' && s+1 < send  && s != start) {
1452                 if (didrange) {
1453                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1454                 }
1455                 if (has_utf8) {
1456                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1457                     s++;
1458                     continue;
1459                 }
1460                 dorange = TRUE;
1461                 s++;
1462             }
1463             else {
1464                 didrange = FALSE;
1465 #ifdef EBCDIC
1466                 literal_endpoint = 0;
1467 #endif
1468             }
1469         }
1470
1471         /* if we get here, we're not doing a transliteration */
1472
1473         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1474            except for the last char, which will be done separately. */
1475         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1476             if (s[2] == '#') {
1477                 while (s+1 < send && *s != ')')
1478                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1479             }
1480             else if (s[2] == '{' /* This should match regcomp.c */
1481                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1482             {
1483                 I32 count = 1;
1484                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1485                 char c;
1486
1487                 while (count && (c = *regparse)) {
1488                     if (c == '\\' && regparse[1])
1489                         regparse++;
1490                     else if (c == '{')
1491                         count++;
1492                     else if (c == '}')
1493                         count--;
1494                     regparse++;
1495                 }
1496                 if (*regparse != ')')
1497                     regparse--;         /* Leave one char for continuation. */
1498                 while (s < regparse)
1499                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1500             }
1501         }
1502
1503         /* likewise skip #-initiated comments in //x patterns */
1504         else if (*s == '#' && PL_lex_inpat &&
1505           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1506             while (s+1 < send && *s != '\n')
1507                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1508         }
1509
1510         /* check for embedded arrays
1511            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1512            */
1513         else if (*s == '@' && s[1]
1514                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1515             break;
1516
1517         /* check for embedded scalars.  only stop if we're sure it's a
1518            variable.
1519         */
1520         else if (*s == '$') {
1521             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1522                 break;
1523             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1524                 break;          /* in regexp, $ might be tail anchor */
1525         }
1526
1527         /* End of else if chain - OP_TRANS rejoin rest */
1528
1529         /* backslashes */
1530         if (*s == '\\' && s+1 < send) {
1531             s++;
1532
1533             /* some backslashes we leave behind */
1534             if (*leaveit && *s && strchr(leaveit, *s)) {
1535                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1536                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1537                 continue;
1538             }
1539
1540             /* deprecate \1 in strings and substitution replacements */
1541             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1542                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1543             {
1544                 if (ckWARN(WARN_SYNTAX))
1545                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1546                 *--s = '$';
1547                 break;
1548             }
1549
1550             /* string-change backslash escapes */
1551             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1552                 --s;
1553                 break;
1554             }
1555
1556             /* if we get here, it's either a quoted -, or a digit */
1557             switch (*s) {
1558
1559             /* quoted - in transliterations */
1560             case '-':
1561                 if (PL_lex_inwhat == OP_TRANS) {
1562                     *d++ = *s++;
1563                     continue;
1564                 }
1565                 /* FALL THROUGH */
1566             default:
1567                 {
1568                     if (isALNUM(*s) &&
1569                         *s != '_' &&
1570                         ckWARN(WARN_MISC))
1571                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1572                                "Unrecognized escape \\%c passed through",
1573                                *s);
1574                     /* default action is to copy the quoted character */
1575                     goto default_action;
1576                 }
1577
1578             /* \132 indicates an octal constant */
1579             case '0': case '1': case '2': case '3':
1580             case '4': case '5': case '6': case '7':
1581                 {
1582                     I32 flags = 0;
1583                     STRLEN len = 3;
1584                     uv = grok_oct(s, &len, &flags, NULL);
1585                     s += len;
1586                 }
1587                 goto NUM_ESCAPE_INSERT;
1588
1589             /* \x24 indicates a hex constant */
1590             case 'x':
1591                 ++s;
1592                 if (*s == '{') {
1593                     char* const e = strchr(s, '}');
1594                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1595                       PERL_SCAN_DISALLOW_PREFIX;
1596                     STRLEN len;
1597
1598                     ++s;
1599                     if (!e) {
1600                         yyerror("Missing right brace on \\x{}");
1601                         continue;
1602                     }
1603                     len = e - s;
1604                     uv = grok_hex(s, &len, &flags, NULL);
1605                     s = e + 1;
1606                 }
1607                 else {
1608                     {
1609                         STRLEN len = 2;
1610                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1611                         uv = grok_hex(s, &len, &flags, NULL);
1612                         s += len;
1613                     }
1614                 }
1615
1616               NUM_ESCAPE_INSERT:
1617                 /* Insert oct or hex escaped character.
1618                  * There will always enough room in sv since such
1619                  * escapes will be longer than any UTF-8 sequence
1620                  * they can end up as. */
1621
1622                 /* We need to map to chars to ASCII before doing the tests
1623                    to cover EBCDIC
1624                 */
1625                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1626                     if (!has_utf8 && uv > 255) {
1627                         /* Might need to recode whatever we have
1628                          * accumulated so far if it contains any
1629                          * hibit chars.
1630                          *
1631                          * (Can't we keep track of that and avoid
1632                          *  this rescan? --jhi)
1633                          */
1634                         int hicount = 0;
1635                         U8 *c;
1636                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1637                             if (!NATIVE_IS_INVARIANT(*c)) {
1638                                 hicount++;
1639                             }
1640                         }
1641                         if (hicount) {
1642                             const STRLEN offset = d - SvPVX_const(sv);
1643                             U8 *src, *dst;
1644                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1645                             src = (U8 *)d - 1;
1646                             dst = src+hicount;
1647                             d  += hicount;
1648                             while (src >= (const U8 *)SvPVX_const(sv)) {
1649                                 if (!NATIVE_IS_INVARIANT(*src)) {
1650                                     const U8 ch = NATIVE_TO_ASCII(*src);
1651                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1652                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1653                                 }
1654                                 else {
1655                                     *dst-- = *src;
1656                                 }
1657                                 src--;
1658                             }
1659                         }
1660                     }
1661
1662                     if (has_utf8 || uv > 255) {
1663                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1664                         has_utf8 = TRUE;
1665                         if (PL_lex_inwhat == OP_TRANS &&
1666                             PL_sublex_info.sub_op) {
1667                             PL_sublex_info.sub_op->op_private |=
1668                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1669                                              : OPpTRANS_TO_UTF);
1670                         }
1671                     }
1672                     else {
1673                         *d++ = (char)uv;
1674                     }
1675                 }
1676                 else {
1677                     *d++ = (char) uv;
1678                 }
1679                 continue;
1680
1681             /* \N{LATIN SMALL LETTER A} is a named character */
1682             case 'N':
1683                 ++s;
1684                 if (*s == '{') {
1685                     char* e = strchr(s, '}');
1686                     SV *res;
1687                     STRLEN len;
1688                     const char *str;
1689
1690                     if (!e) {
1691                         yyerror("Missing right brace on \\N{}");
1692                         e = s - 1;
1693                         goto cont_scan;
1694                     }
1695                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1696                         /* \N{U+...} */
1697                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1698                           PERL_SCAN_DISALLOW_PREFIX;
1699                         s += 3;
1700                         len = e - s;
1701                         uv = grok_hex(s, &len, &flags, NULL);
1702                         s = e + 1;
1703                         goto NUM_ESCAPE_INSERT;
1704                     }
1705                     res = newSVpvn(s + 1, e - s - 1);
1706                     res = new_constant( Nullch, 0, "charnames",
1707                                         res, Nullsv, "\\N{...}" );
1708                     if (has_utf8)
1709                         sv_utf8_upgrade(res);
1710                     str = SvPV_const(res,len);
1711 #ifdef EBCDIC_NEVER_MIND
1712                     /* charnames uses pack U and that has been
1713                      * recently changed to do the below uni->native
1714                      * mapping, so this would be redundant (and wrong,
1715                      * the code point would be doubly converted).
1716                      * But leave this in just in case the pack U change
1717                      * gets revoked, but the semantics is still
1718                      * desireable for charnames. --jhi */
1719                     {
1720                          UV uv = utf8_to_uvchr((const U8*)str, 0);
1721
1722                          if (uv < 0x100) {
1723                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1724
1725                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1726                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1727                               str = SvPV_const(res, len);
1728                          }
1729                     }
1730 #endif
1731                     if (!has_utf8 && SvUTF8(res)) {
1732                         const char * const ostart = SvPVX_const(sv);
1733                         SvCUR_set(sv, d - ostart);
1734                         SvPOK_on(sv);
1735                         *d = '\0';
1736                         sv_utf8_upgrade(sv);
1737                         /* this just broke our allocation above... */
1738                         SvGROW(sv, (STRLEN)(send - start));
1739                         d = SvPVX(sv) + SvCUR(sv);
1740                         has_utf8 = TRUE;
1741                     }
1742                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1743                         const char * const odest = SvPVX_const(sv);
1744
1745                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1746                         d = SvPVX(sv) + (d - odest);
1747                     }
1748                     Copy(str, d, len, char);
1749                     d += len;
1750                     SvREFCNT_dec(res);
1751                   cont_scan:
1752                     s = e + 1;
1753                 }
1754                 else
1755                     yyerror("Missing braces on \\N{}");
1756                 continue;
1757
1758             /* \c is a control character */
1759             case 'c':
1760                 s++;
1761                 if (s < send) {
1762                     U8 c = *s++;
1763 #ifdef EBCDIC
1764                     if (isLOWER(c))
1765                         c = toUPPER(c);
1766 #endif
1767                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1768                 }
1769                 else {
1770                     yyerror("Missing control char name in \\c");
1771                 }
1772                 continue;
1773
1774             /* printf-style backslashes, formfeeds, newlines, etc */
1775             case 'b':
1776                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1777                 break;
1778             case 'n':
1779                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1780                 break;
1781             case 'r':
1782                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1783                 break;
1784             case 'f':
1785                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1786                 break;
1787             case 't':
1788                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1789                 break;
1790             case 'e':
1791                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1792                 break;
1793             case 'a':
1794                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1795                 break;
1796             } /* end switch */
1797
1798             s++;
1799             continue;
1800         } /* end if (backslash) */
1801 #ifdef EBCDIC
1802         else
1803             literal_endpoint++;
1804 #endif
1805
1806     default_action:
1807         /* If we started with encoded form, or already know we want it
1808            and then encode the next character */
1809         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1810             STRLEN len  = 1;
1811             const UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1812             const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1813             s += len;
1814             if (need > len) {
1815                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1816                 const STRLEN off = d - SvPVX_const(sv);
1817                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1818             }
1819             d = (char*)uvchr_to_utf8((U8*)d, uv);
1820             has_utf8 = TRUE;
1821         }
1822         else {
1823             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1824         }
1825     } /* while loop to process each character */
1826
1827     /* terminate the string and set up the sv */
1828     *d = '\0';
1829     SvCUR_set(sv, d - SvPVX_const(sv));
1830     if (SvCUR(sv) >= SvLEN(sv))
1831         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1832
1833     SvPOK_on(sv);
1834     if (PL_encoding && !has_utf8) {
1835         sv_recode_to_utf8(sv, PL_encoding);
1836         if (SvUTF8(sv))
1837             has_utf8 = TRUE;
1838     }
1839     if (has_utf8) {
1840         SvUTF8_on(sv);
1841         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1842             PL_sublex_info.sub_op->op_private |=
1843                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1844         }
1845     }
1846
1847     /* shrink the sv if we allocated more than we used */
1848     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1849         SvPV_shrink_to_cur(sv);
1850     }
1851
1852     /* return the substring (via yylval) only if we parsed anything */
1853     if (s > PL_bufptr) {
1854         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1855             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1856                               sv, Nullsv,
1857                               ( PL_lex_inwhat == OP_TRANS
1858                                 ? "tr"
1859                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1860                                     ? "s"
1861                                     : "qq")));
1862         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1863     } else
1864         SvREFCNT_dec(sv);
1865     return s;
1866 }
1867
1868 /* S_intuit_more
1869  * Returns TRUE if there's more to the expression (e.g., a subscript),
1870  * FALSE otherwise.
1871  *
1872  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1873  *
1874  * ->[ and ->{ return TRUE
1875  * { and [ outside a pattern are always subscripts, so return TRUE
1876  * if we're outside a pattern and it's not { or [, then return FALSE
1877  * if we're in a pattern and the first char is a {
1878  *   {4,5} (any digits around the comma) returns FALSE
1879  * if we're in a pattern and the first char is a [
1880  *   [] returns FALSE
1881  *   [SOMETHING] has a funky algorithm to decide whether it's a
1882  *      character class or not.  It has to deal with things like
1883  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1884  * anything else returns TRUE
1885  */
1886
1887 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1888
1889 STATIC int
1890 S_intuit_more(pTHX_ register char *s)
1891 {
1892     if (PL_lex_brackets)
1893         return TRUE;
1894     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1895         return TRUE;
1896     if (*s != '{' && *s != '[')
1897         return FALSE;
1898     if (!PL_lex_inpat)
1899         return TRUE;
1900
1901     /* In a pattern, so maybe we have {n,m}. */
1902     if (*s == '{') {
1903         s++;
1904         if (!isDIGIT(*s))
1905             return TRUE;
1906         while (isDIGIT(*s))
1907             s++;
1908         if (*s == ',')
1909             s++;
1910         while (isDIGIT(*s))
1911             s++;
1912         if (*s == '}')
1913             return FALSE;
1914         return TRUE;
1915
1916     }
1917
1918     /* On the other hand, maybe we have a character class */
1919
1920     s++;
1921     if (*s == ']' || *s == '^')
1922         return FALSE;
1923     else {
1924         /* this is terrifying, and it works */
1925         int weight = 2;         /* let's weigh the evidence */
1926         char seen[256];
1927         unsigned char un_char = 255, last_un_char;
1928         const char * const send = strchr(s,']');
1929         char tmpbuf[sizeof PL_tokenbuf * 4];
1930
1931         if (!send)              /* has to be an expression */
1932             return TRUE;
1933
1934         Zero(seen,256,char);
1935         if (*s == '$')
1936             weight -= 3;
1937         else if (isDIGIT(*s)) {
1938             if (s[1] != ']') {
1939                 if (isDIGIT(s[1]) && s[2] == ']')
1940                     weight -= 10;
1941             }
1942             else
1943                 weight -= 100;
1944         }
1945         for (; s < send; s++) {
1946             last_un_char = un_char;
1947             un_char = (unsigned char)*s;
1948             switch (*s) {
1949             case '@':
1950             case '&':
1951             case '$':
1952                 weight -= seen[un_char] * 10;
1953                 if (isALNUM_lazy_if(s+1,UTF)) {
1954                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1955                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1956                         weight -= 100;
1957                     else
1958                         weight -= 10;
1959                 }
1960                 else if (*s == '$' && s[1] &&
1961                   strchr("[#!%*<>()-=",s[1])) {
1962                     if (/*{*/ strchr("])} =",s[2]))
1963                         weight -= 10;
1964                     else
1965                         weight -= 1;
1966                 }
1967                 break;
1968             case '\\':
1969                 un_char = 254;
1970                 if (s[1]) {
1971                     if (strchr("wds]",s[1]))
1972                         weight += 100;
1973                     else if (seen['\''] || seen['"'])
1974                         weight += 1;
1975                     else if (strchr("rnftbxcav",s[1]))
1976                         weight += 40;
1977                     else if (isDIGIT(s[1])) {
1978                         weight += 40;
1979                         while (s[1] && isDIGIT(s[1]))
1980                             s++;
1981                     }
1982                 }
1983                 else
1984                     weight += 100;
1985                 break;
1986             case '-':
1987                 if (s[1] == '\\')
1988                     weight += 50;
1989                 if (strchr("aA01! ",last_un_char))
1990                     weight += 30;
1991                 if (strchr("zZ79~",s[1]))
1992                     weight += 30;
1993                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1994                     weight -= 5;        /* cope with negative subscript */
1995                 break;
1996             default:
1997                 if (!isALNUM(last_un_char)
1998                     && !(last_un_char == '$' || last_un_char == '@'
1999                          || last_un_char == '&')
2000                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2001                     char *d = tmpbuf;
2002                     while (isALPHA(*s))
2003                         *d++ = *s++;
2004                     *d = '\0';
2005                     if (keyword(tmpbuf, d - tmpbuf))
2006                         weight -= 150;
2007                 }
2008                 if (un_char == last_un_char + 1)
2009                     weight += 5;
2010                 weight -= seen[un_char];
2011                 break;
2012             }
2013             seen[un_char]++;
2014         }
2015         if (weight >= 0)        /* probably a character class */
2016             return FALSE;
2017     }
2018
2019     return TRUE;
2020 }
2021
2022 /*
2023  * S_intuit_method
2024  *
2025  * Does all the checking to disambiguate
2026  *   foo bar
2027  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2028  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2029  *
2030  * First argument is the stuff after the first token, e.g. "bar".
2031  *
2032  * Not a method if bar is a filehandle.
2033  * Not a method if foo is a subroutine prototyped to take a filehandle.
2034  * Not a method if it's really "Foo $bar"
2035  * Method if it's "foo $bar"
2036  * Not a method if it's really "print foo $bar"
2037  * Method if it's really "foo package::" (interpreted as package->foo)
2038  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2039  * Not a method if bar is a filehandle or package, but is quoted with
2040  *   =>
2041  */
2042
2043 STATIC int
2044 S_intuit_method(pTHX_ char *start, GV *gv)
2045 {
2046     char *s = start + (*start == '$');
2047     char tmpbuf[sizeof PL_tokenbuf];
2048     STRLEN len;
2049     GV* indirgv;
2050
2051     if (gv) {
2052         CV *cv;
2053         if (GvIO(gv))
2054             return 0;
2055         if ((cv = GvCVu(gv))) {
2056             const char *proto = SvPVX_const(cv);
2057             if (proto) {
2058                 if (*proto == ';')
2059                     proto++;
2060                 if (*proto == '*')
2061                     return 0;
2062             }
2063         } else
2064             gv = 0;
2065     }
2066     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2067     /* start is the beginning of the possible filehandle/object,
2068      * and s is the end of it
2069      * tmpbuf is a copy of it
2070      */
2071
2072     if (*start == '$') {
2073         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2074             return 0;
2075         s = skipspace(s);
2076         PL_bufptr = start;
2077         PL_expect = XREF;
2078         return *s == '(' ? FUNCMETH : METHOD;
2079     }
2080     if (!keyword(tmpbuf, len)) {
2081         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2082             len -= 2;
2083             tmpbuf[len] = '\0';
2084             goto bare_package;
2085         }
2086         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2087         if (indirgv && GvCVu(indirgv))
2088             return 0;
2089         /* filehandle or package name makes it a method */
2090         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2091             s = skipspace(s);
2092             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2093                 return 0;       /* no assumptions -- "=>" quotes bearword */
2094       bare_package:
2095             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2096                                                    newSVpvn(tmpbuf,len));
2097             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2098             PL_expect = XTERM;
2099             force_next(WORD);
2100             PL_bufptr = s;
2101             return *s == '(' ? FUNCMETH : METHOD;
2102         }
2103     }
2104     return 0;
2105 }
2106
2107 /*
2108  * S_incl_perldb
2109  * Return a string of Perl code to load the debugger.  If PERL5DB
2110  * is set, it will return the contents of that, otherwise a
2111  * compile-time require of perl5db.pl.
2112  */
2113
2114 STATIC const char*
2115 S_incl_perldb(pTHX)
2116 {
2117     if (PL_perldb) {
2118         const char * const pdb = PerlEnv_getenv("PERL5DB");
2119
2120         if (pdb)
2121             return pdb;
2122         SETERRNO(0,SS_NORMAL);
2123         return "BEGIN { require 'perl5db.pl' }";
2124     }
2125     return "";
2126 }
2127
2128
2129 /* Encoded script support. filter_add() effectively inserts a
2130  * 'pre-processing' function into the current source input stream.
2131  * Note that the filter function only applies to the current source file
2132  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2133  *
2134  * The datasv parameter (which may be NULL) can be used to pass
2135  * private data to this instance of the filter. The filter function
2136  * can recover the SV using the FILTER_DATA macro and use it to
2137  * store private buffers and state information.
2138  *
2139  * The supplied datasv parameter is upgraded to a PVIO type
2140  * and the IoDIRP/IoANY field is used to store the function pointer,
2141  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2142  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2143  * private use must be set using malloc'd pointers.
2144  */
2145
2146 SV *
2147 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2148 {
2149     if (!funcp)
2150         return Nullsv;
2151
2152     if (!PL_rsfp_filters)
2153         PL_rsfp_filters = newAV();
2154     if (!datasv)
2155         datasv = NEWSV(255,0);
2156     SvUPGRADE(datasv, SVt_PVIO);
2157     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2158     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2159     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2160                           IoANY(datasv), SvPV_nolen(datasv)));
2161     av_unshift(PL_rsfp_filters, 1);
2162     av_store(PL_rsfp_filters, 0, datasv) ;
2163     return(datasv);
2164 }
2165
2166
2167 /* Delete most recently added instance of this filter function. */
2168 void
2169 Perl_filter_del(pTHX_ filter_t funcp)
2170 {
2171     SV *datasv;
2172
2173 #ifdef DEBUGGING
2174     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2175 #endif
2176     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2177         return;
2178     /* if filter is on top of stack (usual case) just pop it off */
2179     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2180     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2181         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2182         IoANY(datasv) = (void *)NULL;
2183         sv_free(av_pop(PL_rsfp_filters));
2184
2185         return;
2186     }
2187     /* we need to search for the correct entry and clear it     */
2188     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2189 }
2190
2191
2192 /* Invoke the idxth filter function for the current rsfp.        */
2193 /* maxlen 0 = read one text line */
2194 I32
2195 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2196 {
2197     filter_t funcp;
2198     SV *datasv = NULL;
2199
2200     if (!PL_rsfp_filters)
2201         return -1;
2202     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2203         /* Provide a default input filter to make life easy.    */
2204         /* Note that we append to the line. This is handy.      */
2205         DEBUG_P(PerlIO_printf(Perl_debug_log,
2206                               "filter_read %d: from rsfp\n", idx));
2207         if (maxlen) {
2208             /* Want a block */
2209             int len ;
2210             const int old_len = SvCUR(buf_sv);
2211
2212             /* ensure buf_sv is large enough */
2213             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2214             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2215                 if (PerlIO_error(PL_rsfp))
2216                     return -1;          /* error */
2217                 else
2218                     return 0 ;          /* end of file */
2219             }
2220             SvCUR_set(buf_sv, old_len + len) ;
2221         } else {
2222             /* Want a line */
2223             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2224                 if (PerlIO_error(PL_rsfp))
2225                     return -1;          /* error */
2226                 else
2227                     return 0 ;          /* end of file */
2228             }
2229         }
2230         return SvCUR(buf_sv);
2231     }
2232     /* Skip this filter slot if filter has been deleted */
2233     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2234         DEBUG_P(PerlIO_printf(Perl_debug_log,
2235                               "filter_read %d: skipped (filter deleted)\n",
2236                               idx));
2237         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2238     }
2239     /* Get function pointer hidden within datasv        */
2240     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2241     DEBUG_P(PerlIO_printf(Perl_debug_log,
2242                           "filter_read %d: via function %p (%s)\n",
2243                           idx, datasv, SvPV_nolen_const(datasv)));
2244     /* Call function. The function is expected to       */
2245     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2246     /* Return: <0:error, =0:eof, >0:not eof             */
2247     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2248 }
2249
2250 STATIC char *
2251 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2252 {
2253 #ifdef PERL_CR_FILTER
2254     if (!PL_rsfp_filters) {
2255         filter_add(S_cr_textfilter,NULL);
2256     }
2257 #endif
2258     if (PL_rsfp_filters) {
2259         if (!append)
2260             SvCUR_set(sv, 0);   /* start with empty line        */
2261         if (FILTER_READ(0, sv, 0) > 0)
2262             return ( SvPVX(sv) ) ;
2263         else
2264             return Nullch ;
2265     }
2266     else
2267         return (sv_gets(sv, fp, append));
2268 }
2269
2270 STATIC HV *
2271 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2272 {
2273     GV *gv;
2274
2275     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2276         return PL_curstash;
2277
2278     if (len > 2 &&
2279         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2280         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2281     {
2282         return GvHV(gv);                        /* Foo:: */
2283     }
2284
2285     /* use constant CLASS => 'MyClass' */
2286     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2287         SV *sv;
2288         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2289             pkgname = SvPV_nolen_const(sv);
2290         }
2291     }
2292
2293     return gv_stashpv(pkgname, FALSE);
2294 }
2295
2296 STATIC char *
2297 S_tokenize_use(int is_use, char *s) {
2298     if (PL_expect != XSTATE)
2299         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2300                     is_use ? "use" : "no"));
2301     s = skipspace(s);
2302     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2303         s = force_version(s, TRUE);
2304         if (*s == ';' || (s = skipspace(s), *s == ';')) {
2305             PL_nextval[PL_nexttoke].opval = Nullop;
2306             force_next(WORD);
2307         }
2308         else if (*s == 'v') {
2309             s = force_word(s,WORD,FALSE,TRUE,FALSE);
2310             s = force_version(s, FALSE);
2311         }
2312     }
2313     else {
2314         s = force_word(s,WORD,FALSE,TRUE,FALSE);
2315         s = force_version(s, FALSE);
2316     }
2317     yylval.ival = is_use;
2318     return s;
2319 }
2320 #ifdef DEBUGGING
2321     static const char* const exp_name[] =
2322         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2323           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2324         };
2325 #endif
2326
2327 /*
2328   yylex
2329
2330   Works out what to call the token just pulled out of the input
2331   stream.  The yacc parser takes care of taking the ops we return and
2332   stitching them into a tree.
2333
2334   Returns:
2335     PRIVATEREF
2336
2337   Structure:
2338       if read an identifier
2339           if we're in a my declaration
2340               croak if they tried to say my($foo::bar)
2341               build the ops for a my() declaration
2342           if it's an access to a my() variable
2343               are we in a sort block?
2344                   croak if my($a); $a <=> $b
2345               build ops for access to a my() variable
2346           if in a dq string, and they've said @foo and we can't find @foo
2347               croak
2348           build ops for a bareword
2349       if we already built the token before, use it.
2350 */
2351
2352
2353 #ifdef __SC__
2354 #pragma segment Perl_yylex
2355 #endif
2356 int
2357 Perl_yylex(pTHX)
2358 {
2359     register char *s = PL_bufptr;
2360     register char *d;
2361     register I32 tmp;
2362     STRLEN len;
2363     GV *gv = Nullgv;
2364     GV **gvp = 0;
2365     bool bof = FALSE;
2366     I32 orig_keyword = 0;
2367
2368     DEBUG_T( {
2369         PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2370                                         lex_state_names[PL_lex_state]);
2371     } );
2372     /* check if there's an identifier for us to look at */
2373     if (PL_pending_ident)
2374         return REPORT(S_pending_ident(aTHX));
2375
2376     /* no identifier pending identification */
2377
2378     switch (PL_lex_state) {
2379 #ifdef COMMENTARY
2380     case LEX_NORMAL:            /* Some compilers will produce faster */
2381     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2382         break;
2383 #endif
2384
2385     /* when we've already built the next token, just pull it out of the queue */
2386     case LEX_KNOWNEXT:
2387         PL_nexttoke--;
2388         yylval = PL_nextval[PL_nexttoke];
2389         if (!PL_nexttoke) {
2390             PL_lex_state = PL_lex_defer;
2391             PL_expect = PL_lex_expect;
2392             PL_lex_defer = LEX_NORMAL;
2393         }
2394         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2395               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2396               (IV)PL_nexttype[PL_nexttoke]); });
2397
2398         return REPORT(PL_nexttype[PL_nexttoke]);
2399
2400     /* interpolated case modifiers like \L \U, including \Q and \E.
2401        when we get here, PL_bufptr is at the \
2402     */
2403     case LEX_INTERPCASEMOD:
2404 #ifdef DEBUGGING
2405         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2406             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2407 #endif
2408         /* handle \E or end of string */
2409         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2410             /* if at a \E */
2411             if (PL_lex_casemods) {
2412                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2413                 PL_lex_casestack[PL_lex_casemods] = '\0';
2414
2415                 if (PL_bufptr != PL_bufend
2416                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2417                     PL_bufptr += 2;
2418                     PL_lex_state = LEX_INTERPCONCAT;
2419                 }
2420                 return REPORT(')');
2421             }
2422             if (PL_bufptr != PL_bufend)
2423                 PL_bufptr += 2;
2424             PL_lex_state = LEX_INTERPCONCAT;
2425             return yylex();
2426         }
2427         else {
2428             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2429               "### Saw case modifier at '%s'\n", PL_bufptr); });
2430             s = PL_bufptr + 1;
2431             if (s[1] == '\\' && s[2] == 'E') {
2432                 PL_bufptr = s + 3;
2433                 PL_lex_state = LEX_INTERPCONCAT;
2434                 return yylex();
2435             }
2436             else {
2437                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2438                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2439                 if ((*s == 'L' || *s == 'U') &&
2440                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2441                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2442                     return REPORT(')');
2443                 }
2444                 if (PL_lex_casemods > 10)
2445                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2446                 PL_lex_casestack[PL_lex_casemods++] = *s;
2447                 PL_lex_casestack[PL_lex_casemods] = '\0';
2448                 PL_lex_state = LEX_INTERPCONCAT;
2449                 PL_nextval[PL_nexttoke].ival = 0;
2450                 force_next('(');
2451                 if (*s == 'l')
2452                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2453                 else if (*s == 'u')
2454                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2455                 else if (*s == 'L')
2456                     PL_nextval[PL_nexttoke].ival = OP_LC;
2457                 else if (*s == 'U')
2458                     PL_nextval[PL_nexttoke].ival = OP_UC;
2459                 else if (*s == 'Q')
2460                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2461                 else
2462                     Perl_croak(aTHX_ "panic: yylex");
2463                 PL_bufptr = s + 1;
2464             }
2465             force_next(FUNC);
2466             if (PL_lex_starts) {
2467                 s = PL_bufptr;
2468                 PL_lex_starts = 0;
2469                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2470                 if (PL_lex_casemods == 1 && PL_lex_inpat)
2471                     OPERATOR(',');
2472                 else
2473                     Aop(OP_CONCAT);
2474             }
2475             else
2476                 return yylex();
2477         }
2478
2479     case LEX_INTERPPUSH:
2480         return REPORT(sublex_push());
2481
2482     case LEX_INTERPSTART:
2483         if (PL_bufptr == PL_bufend)
2484             return REPORT(sublex_done());
2485         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2486               "### Interpolated variable at '%s'\n", PL_bufptr); });
2487         PL_expect = XTERM;
2488         PL_lex_dojoin = (*PL_bufptr == '@');
2489         PL_lex_state = LEX_INTERPNORMAL;
2490         if (PL_lex_dojoin) {
2491             PL_nextval[PL_nexttoke].ival = 0;
2492             force_next(',');
2493             force_ident("\"", '$');
2494             PL_nextval[PL_nexttoke].ival = 0;
2495             force_next('$');
2496             PL_nextval[PL_nexttoke].ival = 0;
2497             force_next('(');
2498             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2499             force_next(FUNC);
2500         }
2501         if (PL_lex_starts++) {
2502             s = PL_bufptr;
2503             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2504             if (!PL_lex_casemods && PL_lex_inpat)
2505                 OPERATOR(',');
2506             else
2507                 Aop(OP_CONCAT);
2508         }
2509         return yylex();
2510
2511     case LEX_INTERPENDMAYBE:
2512         if (intuit_more(PL_bufptr)) {
2513             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2514             break;
2515         }
2516         /* FALL THROUGH */
2517
2518     case LEX_INTERPEND:
2519         if (PL_lex_dojoin) {
2520             PL_lex_dojoin = FALSE;
2521             PL_lex_state = LEX_INTERPCONCAT;
2522             return REPORT(')');
2523         }
2524         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2525             && SvEVALED(PL_lex_repl))
2526         {
2527             if (PL_bufptr != PL_bufend)
2528                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2529             PL_lex_repl = Nullsv;
2530         }
2531         /* FALLTHROUGH */
2532     case LEX_INTERPCONCAT:
2533 #ifdef DEBUGGING
2534         if (PL_lex_brackets)
2535             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2536 #endif
2537         if (PL_bufptr == PL_bufend)
2538             return REPORT(sublex_done());
2539
2540         if (SvIVX(PL_linestr) == '\'') {
2541             SV *sv = newSVsv(PL_linestr);
2542             if (!PL_lex_inpat)
2543                 sv = tokeq(sv);
2544             else if ( PL_hints & HINT_NEW_RE )
2545                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2546             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2547             s = PL_bufend;
2548         }
2549         else {
2550             s = scan_const(PL_bufptr);
2551             if (*s == '\\')
2552                 PL_lex_state = LEX_INTERPCASEMOD;
2553             else
2554                 PL_lex_state = LEX_INTERPSTART;
2555         }
2556
2557         if (s != PL_bufptr) {
2558             PL_nextval[PL_nexttoke] = yylval;
2559             PL_expect = XTERM;
2560             force_next(THING);
2561             if (PL_lex_starts++) {
2562                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2563                 if (!PL_lex_casemods && PL_lex_inpat)
2564                     OPERATOR(',');
2565                 else
2566                     Aop(OP_CONCAT);
2567             }
2568             else {
2569                 PL_bufptr = s;
2570                 return yylex();
2571             }
2572         }
2573
2574         return yylex();
2575     case LEX_FORMLINE:
2576         PL_lex_state = LEX_NORMAL;
2577         s = scan_formline(PL_bufptr);
2578         if (!PL_lex_formbrack)
2579             goto rightbracket;
2580         OPERATOR(';');
2581     }
2582
2583     s = PL_bufptr;
2584     PL_oldoldbufptr = PL_oldbufptr;
2585     PL_oldbufptr = s;
2586     DEBUG_T( {
2587         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2588                       exp_name[PL_expect], s);
2589     } );
2590
2591   retry:
2592     switch (*s) {
2593     default:
2594         if (isIDFIRST_lazy_if(s,UTF))
2595             goto keylookup;
2596         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2597     case 4:
2598     case 26:
2599         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2600     case 0:
2601         if (!PL_rsfp) {
2602             PL_last_uni = 0;
2603             PL_last_lop = 0;
2604             if (PL_lex_brackets) {
2605                 if (PL_lex_formbrack)
2606                     yyerror("Format not terminated");
2607                 else
2608                     yyerror("Missing right curly or square bracket");
2609             }
2610             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2611                         "### Tokener got EOF\n");
2612             } );
2613             TOKEN(0);
2614         }
2615         if (s++ < PL_bufend)
2616             goto retry;                 /* ignore stray nulls */
2617         PL_last_uni = 0;
2618         PL_last_lop = 0;
2619         if (!PL_in_eval && !PL_preambled) {
2620             PL_preambled = TRUE;
2621             sv_setpv(PL_linestr,incl_perldb());
2622             if (SvCUR(PL_linestr))
2623                 sv_catpvn(PL_linestr,";", 1);
2624             if (PL_preambleav){
2625                 while(AvFILLp(PL_preambleav) >= 0) {
2626                     SV *tmpsv = av_shift(PL_preambleav);
2627                     sv_catsv(PL_linestr, tmpsv);
2628                     sv_catpvn(PL_linestr, ";", 1);
2629                     sv_free(tmpsv);
2630                 }
2631                 sv_free((SV*)PL_preambleav);
2632                 PL_preambleav = NULL;
2633             }
2634             if (PL_minus_n || PL_minus_p) {
2635                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2636                 if (PL_minus_l)
2637                     sv_catpv(PL_linestr,"chomp;");
2638                 if (PL_minus_a) {
2639                     if (PL_minus_F) {
2640                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2641                              || *PL_splitstr == '"')
2642                               && strchr(PL_splitstr + 1, *PL_splitstr))
2643                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2644                         else {
2645                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2646                                bytes can be used as quoting characters.  :-) */
2647                             /* The count here deliberately includes the NUL
2648                                that terminates the C string constant.  This
2649                                embeds the opening NUL into the string.  */
2650                             const char *splits = PL_splitstr;
2651                             sv_catpvn(PL_linestr, "our @F=split(q", 15);
2652                             do {
2653                                 /* Need to \ \s  */
2654                                 if (*splits == '\\')
2655                                     sv_catpvn(PL_linestr, splits, 1);
2656                                 sv_catpvn(PL_linestr, splits, 1);
2657                             } while (*splits++);
2658                             /* This loop will embed the trailing NUL of
2659                                PL_linestr as the last thing it does before
2660                                terminating.  */
2661                             sv_catpvn(PL_linestr, ");", 2);
2662                         }
2663                     }
2664                     else
2665                         sv_catpv(PL_linestr,"our @F=split(' ');");
2666                 }
2667             }
2668             sv_catpvn(PL_linestr, "\n", 1);
2669             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2670             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2671             PL_last_lop = PL_last_uni = Nullch;
2672             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2673                 SV * const sv = NEWSV(85,0);
2674
2675                 sv_upgrade(sv, SVt_PVMG);
2676                 sv_setsv(sv,PL_linestr);
2677                 (void)SvIOK_on(sv);
2678                 SvIV_set(sv, 0);
2679                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2680             }
2681             goto retry;
2682         }
2683         do {
2684             bof = PL_rsfp ? TRUE : FALSE;
2685             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2686               fake_eof:
2687                 if (PL_rsfp) {
2688                     if (PL_preprocess && !PL_in_eval)
2689                         (void)PerlProc_pclose(PL_rsfp);
2690                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2691                         PerlIO_clearerr(PL_rsfp);
2692                     else
2693                         (void)PerlIO_close(PL_rsfp);
2694                     PL_rsfp = Nullfp;
2695                     PL_doextract = FALSE;
2696                 }
2697                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2698                     sv_setpv(PL_linestr,PL_minus_p
2699                              ? ";}continue{print;}" : ";}");
2700                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2701                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2702                     PL_last_lop = PL_last_uni = Nullch;
2703                     PL_minus_n = PL_minus_p = 0;
2704                     goto retry;
2705                 }
2706                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707                 PL_last_lop = PL_last_uni = Nullch;
2708                 sv_setpvn(PL_linestr,"",0);
2709                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2710             }
2711             /* If it looks like the start of a BOM or raw UTF-16,
2712              * check if it in fact is. */
2713             else if (bof &&
2714                      (*s == 0 ||
2715                       *(U8*)s == 0xEF ||
2716                       *(U8*)s >= 0xFE ||
2717                       s[1] == 0)) {
2718 #ifdef PERLIO_IS_STDIO
2719 #  ifdef __GNU_LIBRARY__
2720 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2721 #      define FTELL_FOR_PIPE_IS_BROKEN
2722 #    endif
2723 #  else
2724 #    ifdef __GLIBC__
2725 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2726 #        define FTELL_FOR_PIPE_IS_BROKEN
2727 #      endif
2728 #    endif
2729 #  endif
2730 #endif
2731 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2732                 /* This loses the possibility to detect the bof
2733                  * situation on perl -P when the libc5 is being used.
2734                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2735                  */
2736                 if (!PL_preprocess)
2737                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2738 #else
2739                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2740 #endif
2741                 if (bof) {
2742                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2743                     s = swallow_bom((U8*)s);
2744                 }
2745             }
2746             if (PL_doextract) {
2747                 /* Incest with pod. */
2748                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2749                     sv_setpvn(PL_linestr, "", 0);
2750                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2751                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2752                     PL_last_lop = PL_last_uni = Nullch;
2753                     PL_doextract = FALSE;
2754                 }
2755             }
2756             incline(s);
2757         } while (PL_doextract);
2758         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2759         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2760             SV * const sv = NEWSV(85,0);
2761
2762             sv_upgrade(sv, SVt_PVMG);
2763             sv_setsv(sv,PL_linestr);
2764             (void)SvIOK_on(sv);
2765             SvIV_set(sv, 0);
2766             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2767         }
2768         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2769         PL_last_lop = PL_last_uni = Nullch;
2770         if (CopLINE(PL_curcop) == 1) {
2771             while (s < PL_bufend && isSPACE(*s))
2772                 s++;
2773             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2774                 s++;
2775             d = Nullch;
2776             if (!PL_in_eval) {
2777                 if (*s == '#' && *(s+1) == '!')
2778                     d = s + 2;
2779 #ifdef ALTERNATE_SHEBANG
2780                 else {
2781                     static char const as[] = ALTERNATE_SHEBANG;
2782                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2783                         d = s + (sizeof(as) - 1);
2784                 }
2785 #endif /* ALTERNATE_SHEBANG */
2786             }
2787             if (d) {
2788                 char *ipath;
2789                 char *ipathend;
2790
2791                 while (isSPACE(*d))
2792                     d++;
2793                 ipath = d;
2794                 while (*d && !isSPACE(*d))
2795                     d++;
2796                 ipathend = d;
2797
2798 #ifdef ARG_ZERO_IS_SCRIPT
2799                 if (ipathend > ipath) {
2800                     /*
2801                      * HP-UX (at least) sets argv[0] to the script name,
2802                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2803                      * at least, set argv[0] to the basename of the Perl
2804                      * interpreter. So, having found "#!", we'll set it right.
2805                      */
2806                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2807                     assert(SvPOK(x) || SvGMAGICAL(x));
2808                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2809                         sv_setpvn(x, ipath, ipathend - ipath);
2810                         SvSETMAGIC(x);
2811                     }
2812                     else {
2813                         STRLEN blen;
2814                         STRLEN llen;
2815                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2816                         const char * const lstart = SvPV_const(x,llen);
2817                         if (llen < blen) {
2818                             bstart += blen - llen;
2819                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2820                                 sv_setpvn(x, ipath, ipathend - ipath);
2821                                 SvSETMAGIC(x);
2822                             }
2823                         }
2824                     }
2825                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2826                 }
2827 #endif /* ARG_ZERO_IS_SCRIPT */
2828
2829                 /*
2830                  * Look for options.
2831                  */
2832                 d = instr(s,"perl -");
2833                 if (!d) {
2834                     d = instr(s,"perl");
2835 #if defined(DOSISH)
2836                     /* avoid getting into infinite loops when shebang
2837                      * line contains "Perl" rather than "perl" */
2838                     if (!d) {
2839                         for (d = ipathend-4; d >= ipath; --d) {
2840                             if ((*d == 'p' || *d == 'P')
2841                                 && !ibcmp(d, "perl", 4))
2842                             {
2843                                 break;
2844                             }
2845                         }
2846                         if (d < ipath)
2847                             d = Nullch;
2848                     }
2849 #endif
2850                 }
2851 #ifdef ALTERNATE_SHEBANG
2852                 /*
2853                  * If the ALTERNATE_SHEBANG on this system starts with a
2854                  * character that can be part of a Perl expression, then if
2855                  * we see it but not "perl", we're probably looking at the
2856                  * start of Perl code, not a request to hand off to some
2857                  * other interpreter.  Similarly, if "perl" is there, but
2858                  * not in the first 'word' of the line, we assume the line
2859                  * contains the start of the Perl program.
2860                  */
2861                 if (d && *s != '#') {
2862                     const char *c = ipath;
2863                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2864                         c++;
2865                     if (c < d)
2866                         d = Nullch;     /* "perl" not in first word; ignore */
2867                     else
2868                         *s = '#';       /* Don't try to parse shebang line */
2869                 }
2870 #endif /* ALTERNATE_SHEBANG */
2871 #ifndef MACOS_TRADITIONAL
2872                 if (!d &&
2873                     *s == '#' &&
2874                     ipathend > ipath &&
2875                     !PL_minus_c &&
2876                     !instr(s,"indir") &&
2877                     instr(PL_origargv[0],"perl"))
2878                 {
2879                     dVAR;
2880                     char **newargv;
2881
2882                     *ipathend = '\0';
2883                     s = ipathend + 1;
2884                     while (s < PL_bufend && isSPACE(*s))
2885                         s++;
2886                     if (s < PL_bufend) {
2887                         Newxz(newargv,PL_origargc+3,char*);
2888                         newargv[1] = s;
2889                         while (s < PL_bufend && !isSPACE(*s))
2890                             s++;
2891                         *s = '\0';
2892                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2893                     }
2894                     else
2895                         newargv = PL_origargv;
2896                     newargv[0] = ipath;
2897                     PERL_FPU_PRE_EXEC
2898                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2899                     PERL_FPU_POST_EXEC
2900                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2901                 }
2902 #endif
2903                 if (d) {
2904                     const U32 oldpdb = PL_perldb;
2905                     const bool oldn = PL_minus_n;
2906                     const bool oldp = PL_minus_p;
2907
2908                     while (*d && !isSPACE(*d)) d++;
2909                     while (SPACE_OR_TAB(*d)) d++;
2910
2911                     if (*d++ == '-') {
2912                         const bool switches_done = PL_doswitches;
2913                         do {
2914                             if (*d == 'M' || *d == 'm' || *d == 'C') {
2915                                 const char * const m = d;
2916                                 while (*d && !isSPACE(*d)) d++;
2917                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2918                                       (int)(d - m), m);
2919                             }
2920                             d = moreswitches(d);
2921                         } while (d);
2922                         if (PL_doswitches && !switches_done) {
2923                             int argc = PL_origargc;
2924                             char **argv = PL_origargv;
2925                             do {
2926                                 argc--,argv++;
2927                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2928                             init_argv_symbols(argc,argv);
2929                         }
2930                         if ((PERLDB_LINE && !oldpdb) ||
2931                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2932                               /* if we have already added "LINE: while (<>) {",
2933                                  we must not do it again */
2934                         {
2935                             sv_setpvn(PL_linestr, "", 0);
2936                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2937                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2938                             PL_last_lop = PL_last_uni = Nullch;
2939                             PL_preambled = FALSE;
2940                             if (PERLDB_LINE)
2941                                 (void)gv_fetchfile(PL_origfilename);
2942                             goto retry;
2943                         }
2944                         if (PL_doswitches && !switches_done) {
2945                             int argc = PL_origargc;
2946                             char **argv = PL_origargv;
2947                             do {
2948                                 argc--,argv++;
2949                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2950                             init_argv_symbols(argc,argv);
2951                         }
2952                     }
2953                 }
2954             }
2955         }
2956         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2957             PL_bufptr = s;
2958             PL_lex_state = LEX_FORMLINE;
2959             return yylex();
2960         }
2961         goto retry;
2962     case '\r':
2963 #ifdef PERL_STRICT_CR
2964         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2965         Perl_croak(aTHX_
2966       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2967 #endif
2968     case ' ': case '\t': case '\f': case 013:
2969 #ifdef MACOS_TRADITIONAL
2970     case '\312':
2971 #endif
2972         s++;
2973         goto retry;
2974     case '#':
2975     case '\n':
2976         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2977             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2978                 /* handle eval qq[#line 1 "foo"\n ...] */
2979                 CopLINE_dec(PL_curcop);
2980                 incline(s);
2981             }
2982             d = PL_bufend;
2983             while (s < d && *s != '\n')
2984                 s++;
2985             if (s < d)
2986                 s++;
2987             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2988               Perl_croak(aTHX_ "panic: input overflow");
2989             incline(s);
2990             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2991                 PL_bufptr = s;
2992                 PL_lex_state = LEX_FORMLINE;
2993                 return yylex();
2994             }
2995         }
2996         else {
2997             *s = '\0';
2998             PL_bufend = s;
2999         }
3000         goto retry;
3001     case '-':
3002         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3003             I32 ftst = 0;
3004
3005             s++;
3006             PL_bufptr = s;
3007             tmp = *s++;
3008
3009             while (s < PL_bufend && SPACE_OR_TAB(*s))
3010                 s++;
3011
3012             if (strnEQ(s,"=>",2)) {
3013                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3014                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3015                             "### Saw unary minus before =>, forcing word '%s'\n", s);
3016                 } );
3017                 OPERATOR('-');          /* unary minus */
3018             }
3019             PL_last_uni = PL_oldbufptr;
3020             switch (tmp) {
3021             case 'r': ftst = OP_FTEREAD;        break;
3022             case 'w': ftst = OP_FTEWRITE;       break;
3023             case 'x': ftst = OP_FTEEXEC;        break;
3024             case 'o': ftst = OP_FTEOWNED;       break;
3025             case 'R': ftst = OP_FTRREAD;        break;
3026             case 'W': ftst = OP_FTRWRITE;       break;
3027             case 'X': ftst = OP_FTREXEC;        break;
3028             case 'O': ftst = OP_FTROWNED;       break;
3029             case 'e': ftst = OP_FTIS;           break;
3030             case 'z': ftst = OP_FTZERO;         break;
3031             case 's': ftst = OP_FTSIZE;         break;
3032             case 'f': ftst = OP_FTFILE;         break;
3033             case 'd': ftst = OP_FTDIR;          break;
3034             case 'l': ftst = OP_FTLINK;         break;
3035             case 'p': ftst = OP_FTPIPE;         break;
3036             case 'S': ftst = OP_FTSOCK;         break;
3037             case 'u': ftst = OP_FTSUID;         break;
3038             case 'g': ftst = OP_FTSGID;         break;
3039             case 'k': ftst = OP_FTSVTX;         break;
3040             case 'b': ftst = OP_FTBLK;          break;
3041             case 'c': ftst = OP_FTCHR;          break;
3042             case 't': ftst = OP_FTTTY;          break;
3043             case 'T': ftst = OP_FTTEXT;         break;
3044             case 'B': ftst = OP_FTBINARY;       break;
3045             case 'M': case 'A': case 'C':
3046                 gv_fetchpv("\024",TRUE, SVt_PV);
3047                 switch (tmp) {
3048                 case 'M': ftst = OP_FTMTIME;    break;
3049                 case 'A': ftst = OP_FTATIME;    break;
3050                 case 'C': ftst = OP_FTCTIME;    break;
3051                 default:                        break;
3052                 }
3053                 break;
3054             default:
3055                 break;
3056             }
3057             if (ftst) {
3058                 PL_last_lop_op = (OPCODE)ftst;
3059                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3060                         "### Saw file test %c\n", (int)ftst);
3061                 } );
3062                 FTST(ftst);
3063             }
3064             else {
3065                 /* Assume it was a minus followed by a one-letter named
3066                  * subroutine call (or a -bareword), then. */
3067                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3068                         "### '-%c' looked like a file test but was not\n",
3069                         (int) tmp);
3070                 } );
3071                 s = --PL_bufptr;
3072             }
3073         }
3074         tmp = *s++;
3075         if (*s == tmp) {
3076             s++;
3077             if (PL_expect == XOPERATOR)
3078                 TERM(POSTDEC);
3079             else
3080                 OPERATOR(PREDEC);
3081         }
3082         else if (*s == '>') {
3083             s++;
3084             s = skipspace(s);
3085             if (isIDFIRST_lazy_if(s,UTF)) {
3086                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3087                 TOKEN(ARROW);
3088             }
3089             else if (*s == '$')
3090                 OPERATOR(ARROW);
3091             else
3092                 TERM(ARROW);
3093         }
3094         if (PL_expect == XOPERATOR)
3095             Aop(OP_SUBTRACT);
3096         else {
3097             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3098                 check_uni();
3099             OPERATOR('-');              /* unary minus */
3100         }
3101
3102     case '+':
3103         tmp = *s++;
3104         if (*s == tmp) {
3105             s++;
3106             if (PL_expect == XOPERATOR)
3107                 TERM(POSTINC);
3108             else
3109                 OPERATOR(PREINC);
3110         }
3111         if (PL_expect == XOPERATOR)
3112             Aop(OP_ADD);
3113         else {
3114             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3115                 check_uni();
3116             OPERATOR('+');
3117         }
3118
3119     case '*':
3120         if (PL_expect != XOPERATOR) {
3121             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3122             PL_expect = XOPERATOR;
3123             force_ident(PL_tokenbuf, '*');
3124             if (!*PL_tokenbuf)
3125                 PREREF('*');
3126             TERM('*');
3127         }
3128         s++;
3129         if (*s == '*') {
3130             s++;
3131             PWop(OP_POW);
3132         }
3133         Mop(OP_MULTIPLY);
3134
3135     case '%':
3136         if (PL_expect == XOPERATOR) {
3137             ++s;
3138             Mop(OP_MODULO);
3139         }
3140         PL_tokenbuf[0] = '%';
3141         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3142         if (!PL_tokenbuf[1]) {
3143             PREREF('%');
3144         }
3145         PL_pending_ident = '%';
3146         TERM('%');
3147
3148     case '^':
3149         s++;
3150         BOop(OP_BIT_XOR);
3151     case '[':
3152         PL_lex_brackets++;
3153         /* FALL THROUGH */
3154     case '~':
3155     case ',':
3156         tmp = *s++;
3157         OPERATOR(tmp);
3158     case ':':
3159         if (s[1] == ':') {
3160             len = 0;
3161             goto just_a_word;
3162         }
3163         s++;
3164         switch (PL_expect) {
3165             OP *attrs;
3166         case XOPERATOR:
3167             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3168                 break;
3169             PL_bufptr = s;      /* update in case we back off */
3170             goto grabattrs;
3171         case XATTRBLOCK:
3172             PL_expect = XBLOCK;
3173             goto grabattrs;
3174         case XATTRTERM:
3175             PL_expect = XTERMBLOCK;
3176          grabattrs:
3177             s = skipspace(s);
3178             attrs = Nullop;
3179             while (isIDFIRST_lazy_if(s,UTF)) {
3180                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3181                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3182                     if (tmp < 0) tmp = -tmp;
3183                     switch (tmp) {
3184                     case KEY_or:
3185                     case KEY_and:
3186                     case KEY_err:
3187                     case KEY_for:
3188                     case KEY_unless:
3189                     case KEY_if:
3190                     case KEY_while:
3191                     case KEY_until:
3192                         goto got_attrs;
3193                     default:
3194                         break;
3195                     }
3196                 }
3197                 if (*d == '(') {
3198                     d = scan_str(d,TRUE,TRUE);
3199                     if (!d) {
3200                         /* MUST advance bufptr here to avoid bogus
3201                            "at end of line" context messages from yyerror().
3202                          */
3203                         PL_bufptr = s + len;
3204                         yyerror("Unterminated attribute parameter in attribute list");
3205                         if (attrs)
3206                             op_free(attrs);
3207                         return REPORT(0);       /* EOF indicator */
3208                     }
3209                 }
3210                 if (PL_lex_stuff) {
3211                     SV *sv = newSVpvn(s, len);
3212                     sv_catsv(sv, PL_lex_stuff);
3213                     attrs = append_elem(OP_LIST, attrs,
3214                                         newSVOP(OP_CONST, 0, sv));
3215                     SvREFCNT_dec(PL_lex_stuff);
3216                     PL_lex_stuff = Nullsv;
3217                 }
3218                 else {
3219                     if (len == 6 && strnEQ(s, "unique", len)) {
3220                         if (PL_in_my == KEY_our)
3221 #ifdef USE_ITHREADS
3222                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3223 #else
3224                             ; /* skip to avoid loading attributes.pm */
3225 #endif
3226                         else
3227                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3228                     }
3229
3230                     /* NOTE: any CV attrs applied here need to be part of
3231                        the CVf_BUILTIN_ATTRS define in cv.h! */
3232                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3233                         CvLVALUE_on(PL_compcv);
3234                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3235                         CvLOCKED_on(PL_compcv);
3236                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3237                         CvMETHOD_on(PL_compcv);
3238                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3239                         CvASSERTION_on(PL_compcv);
3240                     /* After we've set the flags, it could be argued that
3241                        we don't need to do the attributes.pm-based setting
3242                        process, and shouldn't bother appending recognized
3243                        flags.  To experiment with that, uncomment the
3244                        following "else".  (Note that's already been
3245                        uncommented.  That keeps the above-applied built-in
3246                        attributes from being intercepted (and possibly
3247                        rejected) by a package's attribute routines, but is
3248                        justified by the performance win for the common case
3249                        of applying only built-in attributes.) */
3250                     else
3251                         attrs = append_elem(OP_LIST, attrs,
3252                                             newSVOP(OP_CONST, 0,
3253                                                     newSVpvn(s, len)));
3254                 }
3255                 s = skipspace(d);
3256                 if (*s == ':' && s[1] != ':')
3257                     s = skipspace(s+1);
3258                 else if (s == d)
3259                     break;      /* require real whitespace or :'s */
3260             }
3261             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3262             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3263                 const char q = ((*s == '\'') ? '"' : '\'');
3264                 /* If here for an expression, and parsed no attrs, back off. */
3265                 if (tmp == '=' && !attrs) {
3266                     s = PL_bufptr;
3267                     break;
3268                 }
3269                 /* MUST advance bufptr here to avoid bogus "at end of line"
3270                    context messages from yyerror().
3271                  */
3272                 PL_bufptr = s;
3273                 if (!*s)
3274                     yyerror("Unterminated attribute list");
3275                 else
3276                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3277                                       q, *s, q));
3278                 if (attrs)
3279                     op_free(attrs);
3280                 OPERATOR(':');
3281             }
3282         got_attrs:
3283             if (attrs) {
3284                 PL_nextval[PL_nexttoke].opval = attrs;
3285                 force_next(THING);
3286             }
3287             TOKEN(COLONATTR);
3288         }
3289         OPERATOR(':');
3290     case '(':
3291         s++;
3292         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3293             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3294         else
3295             PL_expect = XTERM;
3296         s = skipspace(s);
3297         TOKEN('(');
3298     case ';':
3299         CLINE;
3300         tmp = *s++;
3301         OPERATOR(tmp);
3302     case ')':
3303         tmp = *s++;
3304         s = skipspace(s);
3305         if (*s == '{')
3306             PREBLOCK(tmp);
3307         TERM(tmp);
3308     case ']':
3309         s++;
3310         if (PL_lex_brackets <= 0)
3311             yyerror("Unmatched right square bracket");
3312         else
3313             --PL_lex_brackets;
3314         if (PL_lex_state == LEX_INTERPNORMAL) {
3315             if (PL_lex_brackets == 0) {
3316                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3317                     PL_lex_state = LEX_INTERPEND;
3318             }
3319         }
3320         TERM(']');
3321     case '{':
3322       leftbracket:
3323         s++;
3324         if (PL_lex_brackets > 100) {
3325             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3326         }
3327         switch (PL_expect) {
3328         case XTERM:
3329             if (PL_lex_formbrack) {
3330                 s--;
3331                 PRETERMBLOCK(DO);
3332             }
3333             if (PL_oldoldbufptr == PL_last_lop)
3334                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3335             else
3336                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3337             OPERATOR(HASHBRACK);
3338         case XOPERATOR:
3339             while (s < PL_bufend && SPACE_OR_TAB(*s))
3340                 s++;
3341             d = s;
3342             PL_tokenbuf[0] = '\0';
3343             if (d < PL_bufend && *d == '-') {
3344                 PL_tokenbuf[0] = '-';
3345                 d++;
3346                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3347                     d++;
3348             }
3349             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3350                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3351                               FALSE, &len);
3352                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3353                     d++;
3354                 if (*d == '}') {
3355                     const char minus = (PL_tokenbuf[0] == '-');
3356                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3357                     if (minus)
3358                         force_next('-');
3359                 }
3360             }
3361             /* FALL THROUGH */
3362         case XATTRBLOCK:
3363         case XBLOCK:
3364             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3365             PL_expect = XSTATE;
3366             break;
3367         case XATTRTERM:
3368         case XTERMBLOCK:
3369             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3370             PL_expect = XSTATE;
3371             break;
3372         default: {
3373                 const char *t;
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                 s = skipspace(s);
3379                 if (*s == '}') {
3380                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3381                         PL_expect = XTERM;
3382                         /* This hack is to get the ${} in the message. */
3383                         PL_bufptr = s+1;
3384                         yyerror("syntax error");
3385                         break;
3386                     }
3387                     OPERATOR(HASHBRACK);
3388                 }
3389                 /* This hack serves to disambiguate a pair of curlies
3390                  * as being a block or an anon hash.  Normally, expectation
3391                  * determines that, but in cases where we're not in a
3392                  * position to expect anything in particular (like inside
3393                  * eval"") we have to resolve the ambiguity.  This code
3394                  * covers the case where the first term in the curlies is a
3395                  * quoted string.  Most other cases need to be explicitly
3396                  * disambiguated by prepending a "+" before the opening
3397                  * curly in order to force resolution as an anon hash.
3398                  *
3399                  * XXX should probably propagate the outer expectation
3400                  * into eval"" to rely less on this hack, but that could
3401                  * potentially break current behavior of eval"".
3402                  * GSAR 97-07-21
3403                  */
3404                 t = s;
3405                 if (*s == '\'' || *s == '"' || *s == '`') {
3406                     /* common case: get past first string, handling escapes */
3407                     for (t++; t < PL_bufend && *t != *s;)
3408                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3409                             t++;
3410                     t++;
3411                 }
3412                 else if (*s == 'q') {
3413                     if (++t < PL_bufend
3414                         && (!isALNUM(*t)
3415                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3416                                 && !isALNUM(*t))))
3417                     {
3418                         /* skip q//-like construct */
3419                         const char *tmps;
3420                         char open, close, term;
3421                         I32 brackets = 1;
3422
3423                         while (t < PL_bufend && isSPACE(*t))
3424                             t++;
3425                         /* check for q => */
3426                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3427                             OPERATOR(HASHBRACK);
3428                         }
3429                         term = *t;
3430                         open = term;
3431                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3432                             term = tmps[5];
3433                         close = term;
3434                         if (open == close)
3435                             for (t++; t < PL_bufend; t++) {
3436                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3437                                     t++;
3438                                 else if (*t == open)
3439                                     break;
3440                             }
3441                         else {
3442                             for (t++; t < PL_bufend; t++) {
3443                                 if (*t == '\\' && t+1 < PL_bufend)
3444                                     t++;
3445                                 else if (*t == close && --brackets <= 0)
3446                                     break;
3447                                 else if (*t == open)
3448                                     brackets++;
3449                             }
3450                         }
3451                         t++;
3452                     }
3453                     else
3454                         /* skip plain q word */
3455                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3456                              t += UTF8SKIP(t);
3457                 }
3458                 else if (isALNUM_lazy_if(t,UTF)) {
3459                     t += UTF8SKIP(t);
3460                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3461                          t += UTF8SKIP(t);
3462                 }
3463                 while (t < PL_bufend && isSPACE(*t))
3464                     t++;
3465                 /* if comma follows first term, call it an anon hash */
3466                 /* XXX it could be a comma expression with loop modifiers */
3467                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3468                                    || (*t == '=' && t[1] == '>')))
3469                     OPERATOR(HASHBRACK);
3470                 if (PL_expect == XREF)
3471                     PL_expect = XTERM;
3472                 else {
3473                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3474                     PL_expect = XSTATE;
3475                 }
3476             }
3477             break;
3478         }
3479         yylval.ival = CopLINE(PL_curcop);
3480         if (isSPACE(*s) || *s == '#')
3481             PL_copline = NOLINE;   /* invalidate current command line number */
3482         TOKEN('{');
3483     case '}':
3484       rightbracket:
3485         s++;
3486         if (PL_lex_brackets <= 0)
3487             yyerror("Unmatched right curly bracket");
3488         else
3489             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3490         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3491             PL_lex_formbrack = 0;
3492         if (PL_lex_state == LEX_INTERPNORMAL) {
3493             if (PL_lex_brackets == 0) {
3494                 if (PL_expect & XFAKEBRACK) {
3495                     PL_expect &= XENUMMASK;
3496                     PL_lex_state = LEX_INTERPEND;
3497                     PL_bufptr = s;
3498                     return yylex();     /* ignore fake brackets */
3499                 }
3500                 if (*s == '-' && s[1] == '>')
3501                     PL_lex_state = LEX_INTERPENDMAYBE;
3502                 else if (*s != '[' && *s != '{')
3503                     PL_lex_state = LEX_INTERPEND;
3504             }
3505         }
3506         if (PL_expect & XFAKEBRACK) {
3507             PL_expect &= XENUMMASK;
3508             PL_bufptr = s;
3509             return yylex();             /* ignore fake brackets */
3510         }
3511         force_next('}');
3512         TOKEN(';');
3513     case '&':
3514         s++;
3515         tmp = *s++;
3516         if (tmp == '&')
3517             AOPERATOR(ANDAND);
3518         s--;
3519         if (PL_expect == XOPERATOR) {
3520             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3521                 && isIDFIRST_lazy_if(s,UTF))
3522             {
3523                 CopLINE_dec(PL_curcop);
3524                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3525                 CopLINE_inc(PL_curcop);
3526             }
3527             BAop(OP_BIT_AND);
3528         }
3529
3530         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3531         if (*PL_tokenbuf) {
3532             PL_expect = XOPERATOR;
3533             force_ident(PL_tokenbuf, '&');
3534         }
3535         else
3536             PREREF('&');
3537         yylval.ival = (OPpENTERSUB_AMPER<<8);
3538         TERM('&');
3539
3540     case '|':
3541         s++;
3542         tmp = *s++;
3543         if (tmp == '|')
3544             AOPERATOR(OROR);
3545         s--;
3546         BOop(OP_BIT_OR);
3547     case '=':
3548         s++;
3549         tmp = *s++;
3550         if (tmp == '=')
3551             Eop(OP_EQ);
3552         if (tmp == '>')
3553             OPERATOR(',');
3554         if (tmp == '~')
3555             PMop(OP_MATCH);
3556         if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3557             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3558         s--;
3559         if (PL_expect == XSTATE && isALPHA(tmp) &&
3560                 (s == PL_linestart+1 || s[-2] == '\n') )
3561         {
3562             if (PL_in_eval && !PL_rsfp) {
3563                 d = PL_bufend;
3564                 while (s < d) {
3565                     if (*s++ == '\n') {
3566                         incline(s);
3567                         if (strnEQ(s,"=cut",4)) {
3568                             s = strchr(s,'\n');
3569                             if (s)
3570                                 s++;
3571                             else
3572                                 s = d;
3573                             incline(s);
3574                             goto retry;
3575                         }
3576                     }
3577                 }
3578                 goto retry;
3579             }
3580             s = PL_bufend;
3581             PL_doextract = TRUE;
3582             goto retry;
3583         }
3584         if (PL_lex_brackets < PL_lex_formbrack) {
3585             const char *t;
3586 #ifdef PERL_STRICT_CR
3587             for (t = s; SPACE_OR_TAB(*t); t++) ;
3588 #else
3589             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3590 #endif
3591             if (*t == '\n' || *t == '#') {
3592                 s--;
3593                 PL_expect = XBLOCK;
3594                 goto leftbracket;
3595             }
3596         }
3597         yylval.ival = 0;
3598         OPERATOR(ASSIGNOP);
3599     case '!':
3600         s++;
3601         tmp = *s++;
3602         if (tmp == '=') {
3603             /* was this !=~ where !~ was meant?
3604              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3605
3606             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3607                 const char *t = s+1;
3608
3609                 while (t < PL_bufend && isSPACE(*t))
3610                     ++t;
3611
3612                 if (*t == '/' || *t == '?' ||
3613                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3614                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3615                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3616                                 "!=~ should be !~");
3617             }
3618             Eop(OP_NE);
3619         }
3620         if (tmp == '~')
3621             PMop(OP_NOT);
3622         s--;
3623         OPERATOR('!');
3624     case '<':
3625         if (PL_expect != XOPERATOR) {
3626             if (s[1] != '<' && !strchr(s,'>'))
3627                 check_uni();
3628             if (s[1] == '<')
3629                 s = scan_heredoc(s);
3630             else
3631                 s = scan_inputsymbol(s);
3632             TERM(sublex_start());
3633         }
3634         s++;
3635         tmp = *s++;
3636         if (tmp == '<')
3637             SHop(OP_LEFT_SHIFT);
3638         if (tmp == '=') {
3639             tmp = *s++;
3640             if (tmp == '>')
3641                 Eop(OP_NCMP);
3642             s--;
3643             Rop(OP_LE);
3644         }
3645         s--;
3646         Rop(OP_LT);
3647     case '>':
3648         s++;
3649         tmp = *s++;
3650         if (tmp == '>')
3651             SHop(OP_RIGHT_SHIFT);
3652         if (tmp == '=')
3653             Rop(OP_GE);
3654         s--;
3655         Rop(OP_GT);
3656
3657     case '$':
3658         CLINE;
3659
3660         if (PL_expect == XOPERATOR) {
3661             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3662                 PL_expect = XTERM;
3663                 depcom();
3664                 return REPORT(','); /* grandfather non-comma-format format */
3665             }
3666         }
3667
3668         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3669             PL_tokenbuf[0] = '@';
3670             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3671                            sizeof PL_tokenbuf - 1, FALSE);
3672             if (PL_expect == XOPERATOR)
3673                 no_op("Array length", s);
3674             if (!PL_tokenbuf[1])
3675                 PREREF(DOLSHARP);
3676             PL_expect = XOPERATOR;
3677             PL_pending_ident = '#';
3678             TOKEN(DOLSHARP);
3679         }
3680
3681         PL_tokenbuf[0] = '$';
3682         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3683                        sizeof PL_tokenbuf - 1, FALSE);
3684         if (PL_expect == XOPERATOR)
3685             no_op("Scalar", s);
3686         if (!PL_tokenbuf[1]) {
3687             if (s == PL_bufend)
3688                 yyerror("Final $ should be \\$ or $name");
3689             PREREF('$');
3690         }
3691
3692         /* This kludge not intended to be bulletproof. */
3693         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3694             yylval.opval = newSVOP(OP_CONST, 0,
3695                                    newSViv(PL_compiling.cop_arybase));
3696             yylval.opval->op_private = OPpCONST_ARYBASE;
3697             TERM(THING);
3698         }
3699
3700         d = s;
3701         tmp = (I32)*s;
3702         if (PL_lex_state == LEX_NORMAL)
3703             s = skipspace(s);
3704
3705         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3706             if (*s == '[') {
3707                 PL_tokenbuf[0] = '@';
3708                 if (ckWARN(WARN_SYNTAX)) {
3709                     char *t;
3710                     for(t = s + 1;
3711                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3712                         t++) ;
3713                     if (*t++ == ',') {
3714                         PL_bufptr = skipspace(PL_bufptr);
3715                         while (t < PL_bufend && *t != ']')
3716                             t++;
3717                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3718                                 "Multidimensional syntax %.*s not supported",
3719                                 (t - PL_bufptr) + 1, PL_bufptr);
3720                     }
3721                 }
3722             }
3723             else if (*s == '{') {
3724                 char *t;
3725                 PL_tokenbuf[0] = '%';
3726                 if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
3727                     && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3728                 {
3729                     char tmpbuf[sizeof PL_tokenbuf];
3730                     for (t++; isSPACE(*t); t++) ;
3731                     if (isIDFIRST_lazy_if(t,UTF)) {
3732                         STRLEN len;
3733                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3734                         for (; isSPACE(*t); t++) ;
3735                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3736                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3737                                 "You need to quote \"%s\"", tmpbuf);
3738                     }
3739                 }
3740             }
3741         }
3742
3743         PL_expect = XOPERATOR;
3744         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3745             const bool islop = (PL_last_lop == PL_oldoldbufptr);
3746             if (!islop || PL_last_lop_op == OP_GREPSTART)
3747                 PL_expect = XOPERATOR;
3748             else if (strchr("$@\"'`q", *s))
3749                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3750             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3751                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3752             else if (isIDFIRST_lazy_if(s,UTF)) {
3753                 char tmpbuf[sizeof PL_tokenbuf];
3754                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3755                 if ((tmp = keyword(tmpbuf, len))) {
3756                     /* binary operators exclude handle interpretations */
3757                     switch (tmp) {
3758                     case -KEY_x:
3759                     case -KEY_eq:
3760                     case -KEY_ne:
3761                     case -KEY_gt:
3762                     case -KEY_lt:
3763                     case -KEY_ge:
3764                     case -KEY_le:
3765                     case -KEY_cmp:
3766                         break;
3767                     default:
3768                         PL_expect = XTERM;      /* e.g. print $fh length() */
3769                         break;
3770                     }
3771                 }
3772                 else {
3773                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3774                 }
3775             }
3776             else if (isDIGIT(*s))
3777                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3778             else if (*s == '.' && isDIGIT(s[1]))
3779                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3780             else if ((*s == '?' || *s == '-' || *s == '+')
3781                      && !isSPACE(s[1]) && s[1] != '=')
3782                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3783             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3784                 PL_expect = XTERM;              /* e.g. print $fh /.../
3785                                                  XXX except DORDOR operator */
3786             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3787                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3788         }
3789         PL_pending_ident = '$';
3790         TOKEN('$');
3791
3792     case '@':
3793         if (PL_expect == XOPERATOR)
3794             no_op("Array", s);
3795         PL_tokenbuf[0] = '@';
3796         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3797         if (!PL_tokenbuf[1]) {
3798             PREREF('@');
3799         }
3800         if (PL_lex_state == LEX_NORMAL)
3801             s = skipspace(s);
3802         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3803             if (*s == '{')
3804                 PL_tokenbuf[0] = '%';
3805
3806             /* Warn about @ where they meant $. */
3807             if (*s == '[' || *s == '{') {
3808                 if (ckWARN(WARN_SYNTAX)) {
3809                     const char *t = s + 1;
3810                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3811                         t++;
3812                     if (*t == '}' || *t == ']') {
3813                         t++;
3814                         PL_bufptr = skipspace(PL_bufptr);
3815                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3816                             "Scalar value %.*s better written as $%.*s",
3817                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3818                     }
3819                 }
3820             }
3821         }
3822         PL_pending_ident = '@';
3823         TERM('@');
3824
3825      case '/':                  /* may be division, defined-or, or pattern */
3826         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3827             s += 2;
3828             AOPERATOR(DORDOR);
3829         }
3830      case '?':                  /* may either be conditional or pattern */
3831          if(PL_expect == XOPERATOR) {
3832              tmp = *s++;
3833              if(tmp == '?') {
3834                   OPERATOR('?');
3835              }
3836              else {
3837                  tmp = *s++;
3838                  if(tmp == '/') {
3839                      /* A // operator. */
3840                     AOPERATOR(DORDOR);
3841                  }
3842                  else {
3843                      s--;
3844                      Mop(OP_DIVIDE);
3845                  }
3846              }
3847          }
3848          else {
3849              /* Disable warning on "study /blah/" */
3850              if (PL_oldoldbufptr == PL_last_uni
3851               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3852                   || memNE(PL_last_uni, "study", 5)
3853                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3854               ))
3855                  check_uni();
3856              s = scan_pat(s,OP_MATCH);
3857              TERM(sublex_start());
3858          }
3859
3860     case '.':
3861         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3862 #ifdef PERL_STRICT_CR
3863             && s[1] == '\n'
3864 #else
3865             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3866 #endif
3867             && (s == PL_linestart || s[-1] == '\n') )
3868         {
3869             PL_lex_formbrack = 0;
3870             PL_expect = XSTATE;
3871             goto rightbracket;
3872         }
3873         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3874             tmp = *s++;
3875             if (*s == tmp) {
3876                 s++;
3877                 if (*s == tmp) {
3878                     s++;
3879                     yylval.ival = OPf_SPECIAL;
3880                 }
3881                 else
3882                     yylval.ival = 0;
3883                 OPERATOR(DOTDOT);
3884             }
3885             if (PL_expect != XOPERATOR)
3886                 check_uni();
3887             Aop(OP_CONCAT);
3888         }
3889         /* FALL THROUGH */
3890     case '0': case '1': case '2': case '3': case '4':
3891     case '5': case '6': case '7': case '8': case '9':
3892         s = scan_num(s, &yylval);
3893         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3894                     "### Saw number in '%s'\n", s);
3895         } );
3896         if (PL_expect == XOPERATOR)
3897             no_op("Number",s);
3898         TERM(THING);
3899
3900     case '\'':
3901         s = scan_str(s,FALSE,FALSE);
3902         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3903                     "### Saw string before '%s'\n", s);
3904         } );
3905         if (PL_expect == XOPERATOR) {
3906             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3907                 PL_expect = XTERM;
3908                 depcom();
3909                 return REPORT(','); /* grandfather non-comma-format format */
3910             }
3911             else
3912                 no_op("String",s);
3913         }
3914         if (!s)
3915             missingterm((char*)0);
3916         yylval.ival = OP_CONST;
3917         TERM(sublex_start());
3918
3919     case '"':
3920         s = scan_str(s,FALSE,FALSE);
3921         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3922                     "### Saw string before '%s'\n", s);
3923         } );
3924         if (PL_expect == XOPERATOR) {
3925             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3926                 PL_expect = XTERM;
3927                 depcom();
3928                 return REPORT(','); /* grandfather non-comma-format format */
3929             }
3930             else
3931                 no_op("String",s);
3932         }
3933         if (!s)
3934             missingterm((char*)0);
3935         yylval.ival = OP_CONST;
3936         /* FIXME. I think that this can be const if char *d is replaced by
3937            more localised variables.  */
3938         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3939             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3940                 yylval.ival = OP_STRINGIFY;
3941                 break;
3942             }
3943         }
3944         TERM(sublex_start());
3945
3946     case '`':
3947         s = scan_str(s,FALSE,FALSE);
3948         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3949                     "### Saw backtick string before '%s'\n", s);
3950         } );
3951         if (PL_expect == XOPERATOR)
3952             no_op("Backticks",s);
3953         if (!s)
3954             missingterm((char*)0);
3955         yylval.ival = OP_BACKTICK;
3956         set_csh();
3957         TERM(sublex_start());
3958
3959     case '\\':
3960         s++;
3961         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
3962             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3963                         *s, *s);
3964         if (PL_expect == XOPERATOR)
3965             no_op("Backslash",s);
3966         OPERATOR(REFGEN);
3967
3968     case 'v':
3969         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3970             char *start = s + 2;
3971             while (isDIGIT(*start) || *start == '_')
3972                 start++;
3973             if (*start == '.' && isDIGIT(start[1])) {
3974                 s = scan_num(s, &yylval);
3975                 TERM(THING);
3976             }
3977             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3978             else if (!isALPHA(*start) && (PL_expect == XTERM
3979                         || PL_expect == XREF || PL_expect == XSTATE
3980                         || PL_expect == XTERMORDORDOR)) {
3981                 const char c = *start;
3982                 GV *gv;
3983                 *start = '\0';
3984                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3985                 *start = c;
3986                 if (!gv) {
3987                     s = scan_num(s, &yylval);
3988                     TERM(THING);
3989                 }
3990             }
3991         }
3992         goto keylookup;
3993     case 'x':
3994         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3995             s++;
3996             Mop(OP_REPEAT);
3997         }
3998         goto keylookup;
3999
4000     case '_':
4001     case 'a': case 'A':
4002     case 'b': case 'B':
4003     case 'c': case 'C':
4004     case 'd': case 'D':
4005     case 'e': case 'E':
4006     case 'f': case 'F':
4007     case 'g': case 'G':
4008     case 'h': case 'H':
4009     case 'i': case 'I':
4010     case 'j': case 'J':
4011     case 'k': case 'K':
4012     case 'l': case 'L':
4013     case 'm': case 'M':
4014     case 'n': case 'N':
4015     case 'o': case 'O':
4016     case 'p': case 'P':
4017     case 'q': case 'Q':
4018     case 'r': case 'R':
4019     case 's': case 'S':
4020     case 't': case 'T':
4021     case 'u': case 'U':
4022               case 'V':
4023     case 'w': case 'W':
4024               case 'X':
4025     case 'y': case 'Y':
4026     case 'z': case 'Z':
4027
4028       keylookup: {
4029         orig_keyword = 0;
4030         gv = Nullgv;
4031         gvp = 0;
4032
4033         PL_bufptr = s;
4034         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4035
4036         /* Some keywords can be followed by any delimiter, including ':' */
4037         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4038                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4039                              (PL_tokenbuf[0] == 'q' &&
4040                               strchr("qwxr", PL_tokenbuf[1])))));
4041
4042         /* x::* is just a word, unless x is "CORE" */
4043         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4044             goto just_a_word;
4045
4046         d = s;
4047         while (d < PL_bufend && isSPACE(*d))
4048                 d++;    /* no comments skipped here, or s### is misparsed */
4049
4050         /* Is this a label? */
4051         if (!tmp && PL_expect == XSTATE
4052               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4053             s = d + 1;
4054             yylval.pval = savepv(PL_tokenbuf);
4055             CLINE;
4056             TOKEN(LABEL);
4057         }
4058
4059         /* Check for keywords */
4060         tmp = keyword(PL_tokenbuf, len);
4061
4062         /* Is this a word before a => operator? */
4063         if (*d == '=' && d[1] == '>') {
4064             CLINE;
4065             yylval.opval
4066                 = (OP*)newSVOP(OP_CONST, 0,
4067                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4068             yylval.opval->op_private = OPpCONST_BARE;
4069             TERM(WORD);
4070         }
4071
4072         if (tmp < 0) {                  /* second-class keyword? */
4073             GV *ogv = Nullgv;   /* override (winner) */
4074             GV *hgv = Nullgv;   /* hidden (loser) */
4075             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4076                 CV *cv;
4077                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4078                     (cv = GvCVu(gv)))
4079                 {
4080                     if (GvIMPORTED_CV(gv))
4081                         ogv = gv;
4082                     else if (! CvMETHOD(cv))
4083                         hgv = gv;
4084                 }
4085                 if (!ogv &&
4086                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4087                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4088                     GvCVu(gv) && GvIMPORTED_CV(gv))
4089                 {
4090                     ogv = gv;
4091                 }
4092             }
4093             if (ogv) {
4094                 orig_keyword = tmp;
4095                 tmp = 0;                /* overridden by import or by GLOBAL */
4096             }
4097             else if (gv && !gvp
4098                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4099                      && GvCVu(gv)
4100                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4101             {
4102                 tmp = 0;                /* any sub overrides "weak" keyword */
4103             }
4104             else if (gv && !gvp
4105                     && tmp == -KEY_err
4106                     && GvCVu(gv)
4107                     && PL_expect != XOPERATOR
4108                     && PL_expect != XTERMORDORDOR)
4109             {
4110                 /* any sub overrides the "err" keyword, except when really an
4111                  * operator is expected */
4112                 tmp = 0;
4113             }
4114             else {                      /* no override */
4115                 tmp = -tmp;
4116                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4117                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4118                             "dump() better written as CORE::dump()");
4119                 }
4120                 gv = Nullgv;
4121                 gvp = 0;
4122                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4123                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4124                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4125                         "Ambiguous call resolved as CORE::%s(), %s",
4126                          GvENAME(hgv), "qualify as such or use &");
4127             }
4128         }
4129
4130       reserved_word:
4131         switch (tmp) {
4132
4133         default:                        /* not a keyword */
4134           just_a_word: {
4135                 SV *sv;
4136                 int pkgname = 0;
4137                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4138
4139                 /* Get the rest if it looks like a package qualifier */
4140
4141                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4142                     STRLEN morelen;
4143                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4144                                   TRUE, &morelen);
4145                     if (!morelen)
4146                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4147                                 *s == '\'' ? "'" : "::");
4148                     len += morelen;
4149                     pkgname = 1;
4150                 }
4151
4152                 if (PL_expect == XOPERATOR) {
4153                     if (PL_bufptr == PL_linestart) {
4154                         CopLINE_dec(PL_curcop);
4155                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4156                         CopLINE_inc(PL_curcop);
4157                     }
4158                     else
4159                         no_op("Bareword",s);
4160                 }
4161
4162                 /* Look for a subroutine with this name in current package,
4163                    unless name is "Foo::", in which case Foo is a bearword
4164                    (and a package name). */
4165
4166                 if (len > 2 &&
4167                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4168                 {
4169                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4170                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4171                             "Bareword \"%s\" refers to nonexistent package",
4172                              PL_tokenbuf);
4173                     len -= 2;
4174                     PL_tokenbuf[len] = '\0';
4175                     gv = Nullgv;
4176                     gvp = 0;
4177                 }
4178                 else {
4179                     len = 0;
4180                     if (!gv)
4181                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4182                 }
4183
4184                 /* if we saw a global override before, get the right name */
4185
4186                 if (gvp) {
4187                     sv = newSVpvn("CORE::GLOBAL::",14);
4188                     sv_catpv(sv,PL_tokenbuf);
4189                 }
4190                 else {
4191                     /* If len is 0, newSVpv does strlen(), which is correct.
4192                        If len is non-zero, then it will be the true length,
4193                        and so the scalar will be created correctly.  */
4194                     sv = newSVpv(PL_tokenbuf,len);
4195                 }
4196
4197                 /* Presume this is going to be a bareword of some sort. */
4198
4199                 CLINE;
4200                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4201                 yylval.opval->op_private = OPpCONST_BARE;
4202                 /* UTF-8 package name? */
4203                 if (UTF && !IN_BYTES &&
4204                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4205                     SvUTF8_on(sv);
4206
4207                 /* And if "Foo::", then that's what it certainly is. */
4208
4209                 if (len)
4210                     goto safe_bareword;
4211
4212                 /* See if it's the indirect object for a list operator. */
4213
4214                 if (PL_oldoldbufptr &&
4215                     PL_oldoldbufptr < PL_bufptr &&
4216                     (PL_oldoldbufptr == PL_last_lop
4217                      || PL_oldoldbufptr == PL_last_uni) &&
4218                     /* NO SKIPSPACE BEFORE HERE! */
4219                     (PL_expect == XREF ||
4220                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4221                 {
4222                     bool immediate_paren = *s == '(';
4223
4224                     /* (Now we can afford to cross potential line boundary.) */
4225                     s = skipspace(s);
4226
4227                     /* Two barewords in a row may indicate method call. */
4228
4229                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4230                         return REPORT(tmp);
4231
4232                     /* If not a declared subroutine, it's an indirect object. */
4233                     /* (But it's an indir obj regardless for sort.) */
4234
4235                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4236                          ((!gv || !GvCVu(gv)) &&
4237                         (PL_last_lop_op != OP_MAPSTART &&
4238                          PL_last_lop_op != OP_GREPSTART))))
4239                     {
4240                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4241                         goto bareword;
4242                     }
4243                 }
4244
4245                 PL_expect = XOPERATOR;
4246                 s = skipspace(s);
4247
4248                 /* Is this a word before a => operator? */
4249                 if (*s == '=' && s[1] == '>' && !pkgname) {
4250                     CLINE;
4251                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4252                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4253                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4254                     TERM(WORD);
4255                 }
4256
4257                 /* If followed by a paren, it's certainly a subroutine. */
4258   &nbs