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* 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(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 *oldbp = PL_bufptr;
 379     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 *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 *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     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     New(899, PL_lex_brackstack, 120, char);
 574     New(899, 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(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 *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         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 *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 = SvPVx_const(sv,len);
 975     const char *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(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     New(899, PL_lex_brackstack, 120, char);
1210     New(899, 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 *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
1372     const char *leaveit =       /* set of acceptably-backslashed characters */
1373         PL_lex_inpat
1374             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1375             : "";
1376
1377     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1378         /* If we are doing a trans and we know we want UTF8 set expectation */
1379         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1380         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1381     }
1382
1383
1384     while (s < send || dorange) {
1385         /* get transliterations out of the way (they're most literal) */
1386         if (PL_lex_inwhat == OP_TRANS) {
1387             /* expand a range A-Z to the full set of characters.  AIE! */
1388             if (dorange) {
1389                 I32 i;                          /* current expanded character */
1390                 I32 min;                        /* first character in range */
1391                 I32 max;                        /* last character in range */
1392
1393                 if (has_utf8) {
1394                     char *c = (char*)utf8_hop((U8*)d, -1);
1395                     char *e = d++;
1396                     while (e-- > c)
1397                         *(e + 1) = *e;
1398                     *c = (char)UTF_TO_NATIVE(0xff);
1399                     /* mark the range as done, and continue */
1400                     dorange = FALSE;
1401                     didrange = TRUE;
1402                     continue;
1403                 }
1404
1405                 i = d - SvPVX_const(sv);                /* remember current offset */
1406                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1407                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1408                 d -= 2;                         /* eat the first char and the - */
1409
1410                 min = (U8)*d;                   /* first char in range */
1411                 max = (U8)d[1];                 /* last char in range  */
1412
1413                 if (min > max) {
1414                     Perl_croak(aTHX_
1415                                "Invalid range \"%c-%c\" in transliteration operator",
1416                                (char)min, (char)max);
1417                 }
1418
1419 #ifdef EBCDIC
1420                 if ((isLOWER(min) && isLOWER(max)) ||
1421                     (isUPPER(min) && isUPPER(max))) {
1422                     if (isLOWER(min)) {
1423                         for (i = min; i <= max; i++)
1424                             if (isLOWER(i))
1425                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1426                     } else {
1427                         for (i = min; i <= max; i++)
1428                             if (isUPPER(i))
1429                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1430                     }
1431                 }
1432                 else
1433 #endif
1434                     for (i = min; i <= max; i++)
1435                         *d++ = (char)i;
1436
1437                 /* mark the range as done, and continue */
1438                 dorange = FALSE;
1439                 didrange = TRUE;
1440                 continue;
1441             }
1442
1443             /* range begins (ignore - as first or last char) */
1444             else if (*s == '-' && s+1 < send  && s != start) {
1445                 if (didrange) {
1446                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1447                 }
1448                 if (has_utf8) {
1449                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1450                     s++;
1451                     continue;
1452                 }
1453                 dorange = TRUE;
1454                 s++;
1455             }
1456             else {
1457                 didrange = FALSE;
1458             }
1459         }
1460
1461         /* if we get here, we're not doing a transliteration */
1462
1463         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1464            except for the last char, which will be done separately. */
1465         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1466             if (s[2] == '#') {
1467                 while (s+1 < send && *s != ')')
1468                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1469             }
1470             else if (s[2] == '{' /* This should match regcomp.c */
1471                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1472             {
1473                 I32 count = 1;
1474                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1475                 char c;
1476
1477                 while (count && (c = *regparse)) {
1478                     if (c == '\\' && regparse[1])
1479                         regparse++;
1480                     else if (c == '{')
1481                         count++;
1482                     else if (c == '}')
1483                         count--;
1484                     regparse++;
1485                 }
1486                 if (*regparse != ')')
1487                     regparse--;         /* Leave one char for continuation. */
1488                 while (s < regparse)
1489                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1490             }
1491         }
1492
1493         /* likewise skip #-initiated comments in //x patterns */
1494         else if (*s == '#' && PL_lex_inpat &&
1495           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1496             while (s+1 < send && *s != '\n')
1497                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1498         }
1499
1500         /* check for embedded arrays
1501            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1502            */
1503         else if (*s == '@' && s[1]
1504                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1505             break;
1506
1507         /* check for embedded scalars.  only stop if we're sure it's a
1508            variable.
1509         */
1510         else if (*s == '$') {
1511             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1512                 break;
1513             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1514                 break;          /* in regexp, $ might be tail anchor */
1515         }
1516
1517         /* End of else if chain - OP_TRANS rejoin rest */
1518
1519         /* backslashes */
1520         if (*s == '\\' && s+1 < send) {
1521             s++;
1522
1523             /* some backslashes we leave behind */
1524             if (*leaveit && *s && strchr(leaveit, *s)) {
1525                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1526                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1527                 continue;
1528             }
1529
1530             /* deprecate \1 in strings and substitution replacements */
1531             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1532                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1533             {
1534                 if (ckWARN(WARN_SYNTAX))
1535                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1536                 *--s = '$';
1537                 break;
1538             }
1539
1540             /* string-change backslash escapes */
1541             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1542                 --s;
1543                 break;
1544             }
1545
1546             /* if we get here, it's either a quoted -, or a digit */
1547             switch (*s) {
1548
1549             /* quoted - in transliterations */
1550             case '-':
1551                 if (PL_lex_inwhat == OP_TRANS) {
1552                     *d++ = *s++;
1553                     continue;
1554                 }
1555                 /* FALL THROUGH */
1556             default:
1557                 {
1558                     if (ckWARN(WARN_MISC) &&
1559                         isALNUM(*s) &&
1560                         *s != '_')
1561                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1562                                "Unrecognized escape \\%c passed through",
1563                                *s);
1564                     /* default action is to copy the quoted character */
1565                     goto default_action;
1566                 }
1567
1568             /* \132 indicates an octal constant */
1569             case '0': case '1': case '2': case '3':
1570             case '4': case '5': case '6': case '7':
1571                 {
1572                     I32 flags = 0;
1573                     STRLEN len = 3;
1574                     uv = grok_oct(s, &len, &flags, NULL);
1575                     s += len;
1576                 }
1577                 goto NUM_ESCAPE_INSERT;
1578
1579             /* \x24 indicates a hex constant */
1580             case 'x':
1581                 ++s;
1582                 if (*s == '{') {
1583                     char* e = strchr(s, '}');
1584                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1585                       PERL_SCAN_DISALLOW_PREFIX;
1586                     STRLEN len;
1587
1588                     ++s;
1589                     if (!e) {
1590                         yyerror("Missing right brace on \\x{}");
1591                         continue;
1592                     }
1593                     len = e - s;
1594                     uv = grok_hex(s, &len, &flags, NULL);
1595                     s = e + 1;
1596                 }
1597                 else {
1598                     {
1599                         STRLEN len = 2;
1600                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1601                         uv = grok_hex(s, &len, &flags, NULL);
1602                         s += len;
1603                     }
1604                 }
1605
1606               NUM_ESCAPE_INSERT:
1607                 /* Insert oct or hex escaped character.
1608                  * There will always enough room in sv since such
1609                  * escapes will be longer than any UTF-8 sequence
1610                  * they can end up as. */
1611
1612                 /* We need to map to chars to ASCII before doing the tests
1613                    to cover EBCDIC
1614                 */
1615                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1616                     if (!has_utf8 && uv > 255) {
1617                         /* Might need to recode whatever we have
1618                          * accumulated so far if it contains any
1619                          * hibit chars.
1620                          *
1621                          * (Can't we keep track of that and avoid
1622                          *  this rescan? --jhi)
1623                          */
1624                         int hicount = 0;
1625                         U8 *c;
1626                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1627                             if (!NATIVE_IS_INVARIANT(*c)) {
1628                                 hicount++;
1629                             }
1630                         }
1631                         if (hicount) {
1632                             STRLEN offset = d - SvPVX_const(sv);
1633                             U8 *src, *dst;
1634                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1635                             src = (U8 *)d - 1;
1636                             dst = src+hicount;
1637                             d  += hicount;
1638                             while (src >= (U8 *)SvPVX(sv)) {
1639                                 if (!NATIVE_IS_INVARIANT(*src)) {
1640                                     U8 ch = NATIVE_TO_ASCII(*src);
1641                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1642                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1643                                 }
1644                                 else {
1645                                     *dst-- = *src;
1646                                 }
1647                                 src--;
1648                             }
1649                         }
1650                     }
1651
1652                     if (has_utf8 || uv > 255) {
1653                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1654                         has_utf8 = TRUE;
1655                         if (PL_lex_inwhat == OP_TRANS &&
1656                             PL_sublex_info.sub_op) {
1657                             PL_sublex_info.sub_op->op_private |=
1658                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1659                                              : OPpTRANS_TO_UTF);
1660                         }
1661                     }
1662                     else {
1663                         *d++ = (char)uv;
1664                     }
1665                 }
1666                 else {
1667                     *d++ = (char) uv;
1668                 }
1669                 continue;
1670
1671             /* \N{LATIN SMALL LETTER A} is a named character */
1672             case 'N':
1673                 ++s;
1674                 if (*s == '{') {
1675                     char* e = strchr(s, '}');
1676                     SV *res;
1677                     STRLEN len;
1678                     char *str;
1679
1680                     if (!e) {
1681                         yyerror("Missing right brace on \\N{}");
1682                         e = s - 1;
1683                         goto cont_scan;
1684                     }
1685                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1686                         /* \N{U+...} */
1687                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1688                           PERL_SCAN_DISALLOW_PREFIX;
1689                         s += 3;
1690                         len = e - s;
1691                         uv = grok_hex(s, &len, &flags, NULL);
1692                         s = e + 1;
1693                         goto NUM_ESCAPE_INSERT;
1694                     }
1695                     res = newSVpvn(s + 1, e - s - 1);
1696                     res = new_constant( Nullch, 0, "charnames",
1697                                         res, Nullsv, "\\N{...}" );
1698                     if (has_utf8)
1699                         sv_utf8_upgrade(res);
1700                     str = SvPV(res,len);
1701 #ifdef EBCDIC_NEVER_MIND
1702                     /* charnames uses pack U and that has been
1703                      * recently changed to do the below uni->native
1704                      * mapping, so this would be redundant (and wrong,
1705                      * the code point would be doubly converted).
1706                      * But leave this in just in case the pack U change
1707                      * gets revoked, but the semantics is still
1708                      * desireable for charnames. --jhi */
1709                     {
1710                          UV uv = utf8_to_uvchr((U8*)str, 0);
1711
1712                          if (uv < 0x100) {
1713                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1714
1715                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1716                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1717                               str = SvPV(res, len);
1718                          }
1719                     }
1720 #endif
1721                     if (!has_utf8 && SvUTF8(res)) {
1722                         const char *ostart = SvPVX_const(sv);
1723                         SvCUR_set(sv, d - ostart);
1724                         SvPOK_on(sv);
1725                         *d = '\0';
1726                         sv_utf8_upgrade(sv);
1727                         /* this just broke our allocation above... */
1728                         SvGROW(sv, (STRLEN)(send - start));
1729                         d = SvPVX(sv) + SvCUR(sv);
1730                         has_utf8 = TRUE;
1731                     }
1732                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1733                         const char *odest = SvPVX_const(sv);
1734
1735                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1736                         d = SvPVX(sv) + (d - odest);
1737                     }
1738                     Copy(str, d, len, char);
1739                     d += len;
1740                     SvREFCNT_dec(res);
1741                   cont_scan:
1742                     s = e + 1;
1743                 }
1744                 else
1745                     yyerror("Missing braces on \\N{}");
1746                 continue;
1747
1748             /* \c is a control character */
1749             case 'c':
1750                 s++;
1751                 if (s < send) {
1752                     U8 c = *s++;
1753 #ifdef EBCDIC
1754                     if (isLOWER(c))
1755                         c = toUPPER(c);
1756 #endif
1757                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1758                 }
1759                 else {
1760                     yyerror("Missing control char name in \\c");
1761                 }
1762                 continue;
1763
1764             /* printf-style backslashes, formfeeds, newlines, etc */
1765             case 'b':
1766                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1767                 break;
1768             case 'n':
1769                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1770                 break;
1771             case 'r':
1772                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1773                 break;
1774             case 'f':
1775                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1776                 break;
1777             case 't':
1778                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1779                 break;
1780             case 'e':
1781                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1782                 break;
1783             case 'a':
1784                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1785                 break;
1786             } /* end switch */
1787
1788             s++;
1789             continue;
1790         } /* end if (backslash) */
1791
1792     default_action:
1793         /* If we started with encoded form, or already know we want it
1794            and then encode the next character */
1795         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1796             STRLEN len  = 1;
1797             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1798             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1799             s += len;
1800             if (need > len) {
1801                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1802                 STRLEN off = d - SvPVX_const(sv);
1803                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1804             }
1805             d = (char*)uvchr_to_utf8((U8*)d, uv);
1806             has_utf8 = TRUE;
1807         }
1808         else {
1809             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1810         }
1811     } /* while loop to process each character */
1812
1813     /* terminate the string and set up the sv */
1814     *d = '\0';
1815     SvCUR_set(sv, d - SvPVX_const(sv));
1816     if (SvCUR(sv) >= SvLEN(sv))
1817         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1818
1819     SvPOK_on(sv);
1820     if (PL_encoding && !has_utf8) {
1821         sv_recode_to_utf8(sv, PL_encoding);
1822         if (SvUTF8(sv))
1823             has_utf8 = TRUE;
1824     }
1825     if (has_utf8) {
1826         SvUTF8_on(sv);
1827         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1828             PL_sublex_info.sub_op->op_private |=
1829                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1830         }
1831     }
1832
1833     /* shrink the sv if we allocated more than we used */
1834     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1835         SvPV_shrink_to_cur(sv);
1836     }
1837
1838     /* return the substring (via yylval) only if we parsed anything */
1839     if (s > PL_bufptr) {
1840         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1841             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1842                               sv, Nullsv,
1843                               ( PL_lex_inwhat == OP_TRANS
1844                                 ? "tr"
1845                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1846                                     ? "s"
1847                                     : "qq")));
1848         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1849     } else
1850         SvREFCNT_dec(sv);
1851     return s;
1852 }
1853
1854 /* S_intuit_more
1855  * Returns TRUE if there's more to the expression (e.g., a subscript),
1856  * FALSE otherwise.
1857  *
1858  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1859  *
1860  * ->[ and ->{ return TRUE
1861  * { and [ outside a pattern are always subscripts, so return TRUE
1862  * if we're outside a pattern and it's not { or [, then return FALSE
1863  * if we're in a pattern and the first char is a {
1864  *   {4,5} (any digits around the comma) returns FALSE
1865  * if we're in a pattern and the first char is a [
1866  *   [] returns FALSE
1867  *   [SOMETHING] has a funky algorithm to decide whether it's a
1868  *      character class or not.  It has to deal with things like
1869  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1870  * anything else returns TRUE
1871  */
1872
1873 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1874
1875 STATIC int
1876 S_intuit_more(pTHX_ register char *s)
1877 {
1878     if (PL_lex_brackets)
1879         return TRUE;
1880     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1881         return TRUE;
1882     if (*s != '{' && *s != '[')
1883         return FALSE;
1884     if (!PL_lex_inpat)
1885         return TRUE;
1886
1887     /* In a pattern, so maybe we have {n,m}. */
1888     if (*s == '{') {
1889         s++;
1890         if (!isDIGIT(*s))
1891             return TRUE;
1892         while (isDIGIT(*s))
1893             s++;
1894         if (*s == ',')
1895             s++;
1896         while (isDIGIT(*s))
1897             s++;
1898         if (*s == '}')
1899             return FALSE;
1900         return TRUE;
1901
1902     }
1903
1904     /* On the other hand, maybe we have a character class */
1905
1906     s++;
1907     if (*s == ']' || *s == '^')
1908         return FALSE;
1909     else {
1910         /* this is terrifying, and it works */
1911         int weight = 2;         /* let's weigh the evidence */
1912         char seen[256];
1913         unsigned char un_char = 255, last_un_char;
1914         const char *send = strchr(s,']');
1915         char tmpbuf[sizeof PL_tokenbuf * 4];
1916
1917         if (!send)              /* has to be an expression */
1918             return TRUE;
1919
1920         Zero(seen,256,char);
1921         if (*s == '$')
1922             weight -= 3;
1923         else if (isDIGIT(*s)) {
1924             if (s[1] != ']') {
1925                 if (isDIGIT(s[1]) && s[2] == ']')
1926                     weight -= 10;
1927             }
1928             else
1929                 weight -= 100;
1930         }
1931         for (; s < send; s++) {
1932             last_un_char = un_char;
1933             un_char = (unsigned char)*s;
1934             switch (*s) {
1935             case '@':
1936             case '&':
1937             case '$':
1938                 weight -= seen[un_char] * 10;
1939                 if (isALNUM_lazy_if(s+1,UTF)) {
1940                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1941                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1942                         weight -= 100;
1943                     else
1944                         weight -= 10;
1945                 }
1946                 else if (*s == '$' && s[1] &&
1947                   strchr("[#!%*<>()-=",s[1])) {
1948                     if (/*{*/ strchr("])} =",s[2]))
1949                         weight -= 10;
1950                     else
1951                         weight -= 1;
1952                 }
1953                 break;
1954             case '\\':
1955                 un_char = 254;
1956                 if (s[1]) {
1957                     if (strchr("wds]",s[1]))
1958                         weight += 100;
1959                     else if (seen['\''] || seen['"'])
1960                         weight += 1;
1961                     else if (strchr("rnftbxcav",s[1]))
1962                         weight += 40;
1963                     else if (isDIGIT(s[1])) {
1964                         weight += 40;
1965                         while (s[1] && isDIGIT(s[1]))
1966                             s++;
1967                     }
1968                 }
1969                 else
1970                     weight += 100;
1971                 break;
1972             case '-':
1973                 if (s[1] == '\\')
1974                     weight += 50;
1975                 if (strchr("aA01! ",last_un_char))
1976                     weight += 30;
1977                 if (strchr("zZ79~",s[1]))
1978                     weight += 30;
1979                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1980                     weight -= 5;        /* cope with negative subscript */
1981                 break;
1982             default:
1983                 if (!isALNUM(last_un_char)
1984                     && !(last_un_char == '$' || last_un_char == '@'
1985                          || last_un_char == '&')
1986                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
1987                     char *d = tmpbuf;
1988                     while (isALPHA(*s))
1989                         *d++ = *s++;
1990                     *d = '\0';
1991                     if (keyword(tmpbuf, d - tmpbuf))
1992                         weight -= 150;
1993                 }
1994                 if (un_char == last_un_char + 1)
1995                     weight += 5;
1996                 weight -= seen[un_char];
1997                 break;
1998             }
1999             seen[un_char]++;
2000         }
2001         if (weight >= 0)        /* probably a character class */
2002             return FALSE;
2003     }
2004
2005     return TRUE;
2006 }
2007
2008 /*
2009  * S_intuit_method
2010  *
2011  * Does all the checking to disambiguate
2012  *   foo bar
2013  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2014  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2015  *
2016  * First argument is the stuff after the first token, e.g. "bar".
2017  *
2018  * Not a method if bar is a filehandle.
2019  * Not a method if foo is a subroutine prototyped to take a filehandle.
2020  * Not a method if it's really "Foo $bar"
2021  * Method if it's "foo $bar"
2022  * Not a method if it's really "print foo $bar"
2023  * Method if it's really "foo package::" (interpreted as package->foo)
2024  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2025  * Not a method if bar is a filehandle or package, but is quoted with
2026  *   =>
2027  */
2028
2029 STATIC int
2030 S_intuit_method(pTHX_ char *start, GV *gv)
2031 {
2032     char *s = start + (*start == '$');
2033     char tmpbuf[sizeof PL_tokenbuf];
2034     STRLEN len;
2035     GV* indirgv;
2036
2037     if (gv) {
2038         CV *cv;
2039         if (GvIO(gv))
2040             return 0;
2041         if ((cv = GvCVu(gv))) {
2042             const char *proto = SvPVX_const(cv);
2043             if (proto) {
2044                 if (*proto == ';')
2045                     proto++;
2046                 if (*proto == '*')
2047                     return 0;
2048             }
2049         } else
2050             gv = 0;
2051     }
2052     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2053     /* start is the beginning of the possible filehandle/object,
2054      * and s is the end of it
2055      * tmpbuf is a copy of it
2056      */
2057
2058     if (*start == '$') {
2059         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2060             return 0;
2061         s = skipspace(s);
2062         PL_bufptr = start;
2063         PL_expect = XREF;
2064         return *s == '(' ? FUNCMETH : METHOD;
2065     }
2066     if (!keyword(tmpbuf, len)) {
2067         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2068             len -= 2;
2069             tmpbuf[len] = '\0';
2070             goto bare_package;
2071         }
2072         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2073         if (indirgv && GvCVu(indirgv))
2074             return 0;
2075         /* filehandle or package name makes it a method */
2076         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2077             s = skipspace(s);
2078             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2079                 return 0;       /* no assumptions -- "=>" quotes bearword */
2080       bare_package:
2081             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2082                                                    newSVpvn(tmpbuf,len));
2083             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2084             PL_expect = XTERM;
2085             force_next(WORD);
2086             PL_bufptr = s;
2087             return *s == '(' ? FUNCMETH : METHOD;
2088         }
2089     }
2090     return 0;
2091 }
2092
2093 /*
2094  * S_incl_perldb
2095  * Return a string of Perl code to load the debugger.  If PERL5DB
2096  * is set, it will return the contents of that, otherwise a
2097  * compile-time require of perl5db.pl.
2098  */
2099
2100 STATIC const char*
2101 S_incl_perldb(pTHX)
2102 {
2103     if (PL_perldb) {
2104         const char *pdb = PerlEnv_getenv("PERL5DB");
2105
2106         if (pdb)
2107             return pdb;
2108         SETERRNO(0,SS_NORMAL);
2109         return "BEGIN { require 'perl5db.pl' }";
2110     }
2111     return "";
2112 }
2113
2114
2115 /* Encoded script support. filter_add() effectively inserts a
2116  * 'pre-processing' function into the current source input stream.
2117  * Note that the filter function only applies to the current source file
2118  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2119  *
2120  * The datasv parameter (which may be NULL) can be used to pass
2121  * private data to this instance of the filter. The filter function
2122  * can recover the SV using the FILTER_DATA macro and use it to
2123  * store private buffers and state information.
2124  *
2125  * The supplied datasv parameter is upgraded to a PVIO type
2126  * and the IoDIRP/IoANY field is used to store the function pointer,
2127  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2128  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2129  * private use must be set using malloc'd pointers.
2130  */
2131
2132 SV *
2133 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2134 {
2135     if (!funcp)
2136         return Nullsv;
2137
2138     if (!PL_rsfp_filters)
2139         PL_rsfp_filters = newAV();
2140     if (!datasv)
2141         datasv = NEWSV(255,0);
2142     SvUPGRADE(datasv, SVt_PVIO);
2143     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2144     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2145     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2146                           IoANY(datasv), SvPV_nolen(datasv)));
2147     av_unshift(PL_rsfp_filters, 1);
2148     av_store(PL_rsfp_filters, 0, datasv) ;
2149     return(datasv);
2150 }
2151
2152
2153 /* Delete most recently added instance of this filter function. */
2154 void
2155 Perl_filter_del(pTHX_ filter_t funcp)
2156 {
2157     SV *datasv;
2158
2159 #ifdef DEBUGGING
2160     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2161 #endif
2162     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2163         return;
2164     /* if filter is on top of stack (usual case) just pop it off */
2165     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2166     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2167         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2168         IoANY(datasv) = (void *)NULL;
2169         sv_free(av_pop(PL_rsfp_filters));
2170
2171         return;
2172     }
2173     /* we need to search for the correct entry and clear it     */
2174     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2175 }
2176
2177
2178 /* Invoke the idxth filter function for the current rsfp.        */
2179 /* maxlen 0 = read one text line */
2180 I32
2181 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2182 {
2183     filter_t funcp;
2184     SV *datasv = NULL;
2185
2186     if (!PL_rsfp_filters)
2187         return -1;
2188     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2189         /* Provide a default input filter to make life easy.    */
2190         /* Note that we append to the line. This is handy.      */
2191         DEBUG_P(PerlIO_printf(Perl_debug_log,
2192                               "filter_read %d: from rsfp\n", idx));
2193         if (maxlen) {
2194             /* Want a block */
2195             int len ;
2196             const int old_len = SvCUR(buf_sv);
2197
2198             /* ensure buf_sv is large enough */
2199             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2200             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2201                 if (PerlIO_error(PL_rsfp))
2202                     return -1;          /* error */
2203                 else
2204                     return 0 ;          /* end of file */
2205             }
2206             SvCUR_set(buf_sv, old_len + len) ;
2207         } else {
2208             /* Want a line */
2209             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2210                 if (PerlIO_error(PL_rsfp))
2211                     return -1;          /* error */
2212                 else
2213                     return 0 ;          /* end of file */
2214             }
2215         }
2216         return SvCUR(buf_sv);
2217     }
2218     /* Skip this filter slot if filter has been deleted */
2219     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2220         DEBUG_P(PerlIO_printf(Perl_debug_log,
2221                               "filter_read %d: skipped (filter deleted)\n",
2222                               idx));
2223         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2224     }
2225     /* Get function pointer hidden within datasv        */
2226     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2227     DEBUG_P(PerlIO_printf(Perl_debug_log,
2228                           "filter_read %d: via function %p (%s)\n",
2229                           idx, datasv, SvPV_nolen(datasv)));
2230     /* Call function. The function is expected to       */
2231     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2232     /* Return: <0:error, =0:eof, >0:not eof             */
2233     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2234 }
2235
2236 STATIC char *
2237 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2238 {
2239 #ifdef PERL_CR_FILTER
2240     if (!PL_rsfp_filters) {
2241         filter_add(S_cr_textfilter,NULL);
2242     }
2243 #endif
2244     if (PL_rsfp_filters) {
2245         if (!append)
2246             SvCUR_set(sv, 0);   /* start with empty line        */
2247         if (FILTER_READ(0, sv, 0) > 0)
2248             return ( SvPVX(sv) ) ;
2249         else
2250             return Nullch ;
2251     }
2252     else
2253         return (sv_gets(sv, fp, append));
2254 }
2255
2256 STATIC HV *
2257 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2258 {
2259     GV *gv;
2260
2261     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2262         return PL_curstash;
2263
2264     if (len > 2 &&
2265         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2266         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2267     {
2268         return GvHV(gv);                        /* Foo:: */
2269     }
2270
2271     /* use constant CLASS => 'MyClass' */
2272     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2273         SV *sv;
2274         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2275             pkgname = SvPV_nolen_const(sv);
2276         }
2277     }
2278
2279     return gv_stashpv(pkgname, FALSE);
2280 }
2281
2282 #ifdef DEBUGGING
2283     static const char* const exp_name[] =
2284         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2285           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2286         };
2287 #endif
2288
2289 /*
2290   yylex
2291
2292   Works out what to call the token just pulled out of the input
2293   stream.  The yacc parser takes care of taking the ops we return and
2294   stitching them into a tree.
2295
2296   Returns:
2297     PRIVATEREF
2298
2299   Structure:
2300       if read an identifier
2301           if we're in a my declaration
2302               croak if they tried to say my($foo::bar)
2303               build the ops for a my() declaration
2304           if it's an access to a my() variable
2305               are we in a sort block?
2306                   croak if my($a); $a <=> $b
2307               build ops for access to a my() variable
2308           if in a dq string, and they've said @foo and we can't find @foo
2309               croak
2310           build ops for a bareword
2311       if we already built the token before, use it.
2312 */
2313
2314
2315 #ifdef __SC__
2316 #pragma segment Perl_yylex
2317 #endif
2318 int
2319 Perl_yylex(pTHX)
2320 {
2321     register char *s = PL_bufptr;
2322     register char *d;
2323     register I32 tmp;
2324     STRLEN len;
2325     GV *gv = Nullgv;
2326     GV **gvp = 0;
2327     bool bof = FALSE;
2328     I32 orig_keyword = 0;
2329
2330     DEBUG_T( {
2331         PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2332                                         lex_state_names[PL_lex_state]);
2333     } );
2334     /* check if there's an identifier for us to look at */
2335     if (PL_pending_ident)
2336         return REPORT(S_pending_ident(aTHX));
2337
2338     /* no identifier pending identification */
2339
2340     switch (PL_lex_state) {
2341 #ifdef COMMENTARY
2342     case LEX_NORMAL:            /* Some compilers will produce faster */
2343     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2344         break;
2345 #endif
2346
2347     /* when we've already built the next token, just pull it out of the queue */
2348     case LEX_KNOWNEXT:
2349         PL_nexttoke--;
2350         yylval = PL_nextval[PL_nexttoke];
2351         if (!PL_nexttoke) {
2352             PL_lex_state = PL_lex_defer;
2353             PL_expect = PL_lex_expect;
2354             PL_lex_defer = LEX_NORMAL;
2355         }
2356         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2357               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2358               (IV)PL_nexttype[PL_nexttoke]); });
2359
2360         return REPORT(PL_nexttype[PL_nexttoke]);
2361
2362     /* interpolated case modifiers like \L \U, including \Q and \E.
2363        when we get here, PL_bufptr is at the \
2364     */
2365     case LEX_INTERPCASEMOD:
2366 #ifdef DEBUGGING
2367         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2368             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2369 #endif
2370         /* handle \E or end of string */
2371         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2372             /* if at a \E */
2373             if (PL_lex_casemods) {
2374                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2375                 PL_lex_casestack[PL_lex_casemods] = '\0';
2376
2377                 if (PL_bufptr != PL_bufend
2378                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2379                     PL_bufptr += 2;
2380                     PL_lex_state = LEX_INTERPCONCAT;
2381                 }
2382                 return REPORT(')');
2383             }
2384             if (PL_bufptr != PL_bufend)
2385                 PL_bufptr += 2;
2386             PL_lex_state = LEX_INTERPCONCAT;
2387             return yylex();
2388         }
2389         else {
2390             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2391               "### Saw case modifier at '%s'\n", PL_bufptr); });
2392             s = PL_bufptr + 1;
2393             if (s[1] == '\\' && s[2] == 'E') {
2394                 PL_bufptr = s + 3;
2395                 PL_lex_state = LEX_INTERPCONCAT;
2396                 return yylex();
2397             }
2398             else {
2399                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2400                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2401                 if ((*s == 'L' || *s == 'U') &&
2402                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2403                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2404                     return REPORT(')');
2405                 }
2406                 if (PL_lex_casemods > 10)
2407                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2408                 PL_lex_casestack[PL_lex_casemods++] = *s;
2409                 PL_lex_casestack[PL_lex_casemods] = '\0';
2410                 PL_lex_state = LEX_INTERPCONCAT;
2411                 PL_nextval[PL_nexttoke].ival = 0;
2412                 force_next('(');
2413                 if (*s == 'l')
2414                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2415                 else if (*s == 'u')
2416                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2417                 else if (*s == 'L')
2418                     PL_nextval[PL_nexttoke].ival = OP_LC;
2419                 else if (*s == 'U')
2420                     PL_nextval[PL_nexttoke].ival = OP_UC;
2421                 else if (*s == 'Q')
2422                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2423                 else
2424                     Perl_croak(aTHX_ "panic: yylex");
2425                 PL_bufptr = s + 1;
2426             }
2427             force_next(FUNC);
2428             if (PL_lex_starts) {
2429                 s = PL_bufptr;
2430                 PL_lex_starts = 0;
2431                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2432                 if (PL_lex_casemods == 1 && PL_lex_inpat)
2433                     OPERATOR(',');
2434                 else
2435                     Aop(OP_CONCAT);
2436             }
2437             else
2438                 return yylex();
2439         }
2440
2441     case LEX_INTERPPUSH:
2442         return REPORT(sublex_push());
2443
2444     case LEX_INTERPSTART:
2445         if (PL_bufptr == PL_bufend)
2446             return REPORT(sublex_done());
2447         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2448               "### Interpolated variable at '%s'\n", PL_bufptr); });
2449         PL_expect = XTERM;
2450         PL_lex_dojoin = (*PL_bufptr == '@');
2451         PL_lex_state = LEX_INTERPNORMAL;
2452         if (PL_lex_dojoin) {
2453             PL_nextval[PL_nexttoke].ival = 0;
2454             force_next(',');
2455             force_ident("\"", '$');
2456             PL_nextval[PL_nexttoke].ival = 0;
2457             force_next('$');
2458             PL_nextval[PL_nexttoke].ival = 0;
2459             force_next('(');
2460             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2461             force_next(FUNC);
2462         }
2463         if (PL_lex_starts++) {
2464             s = PL_bufptr;
2465             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2466             if (!PL_lex_casemods && PL_lex_inpat)
2467                 OPERATOR(',');
2468             else
2469                 Aop(OP_CONCAT);
2470         }
2471         return yylex();
2472
2473     case LEX_INTERPENDMAYBE:
2474         if (intuit_more(PL_bufptr)) {
2475             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2476             break;
2477         }
2478         /* FALL THROUGH */
2479
2480     case LEX_INTERPEND:
2481         if (PL_lex_dojoin) {
2482             PL_lex_dojoin = FALSE;
2483             PL_lex_state = LEX_INTERPCONCAT;
2484             return REPORT(')');
2485         }
2486         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2487             && SvEVALED(PL_lex_repl))
2488         {
2489             if (PL_bufptr != PL_bufend)
2490                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2491             PL_lex_repl = Nullsv;
2492         }
2493         /* FALLTHROUGH */
2494     case LEX_INTERPCONCAT:
2495 #ifdef DEBUGGING
2496         if (PL_lex_brackets)
2497             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2498 #endif
2499         if (PL_bufptr == PL_bufend)
2500             return REPORT(sublex_done());
2501
2502         if (SvIVX(PL_linestr) == '\'') {
2503             SV *sv = newSVsv(PL_linestr);
2504             if (!PL_lex_inpat)
2505                 sv = tokeq(sv);
2506             else if ( PL_hints & HINT_NEW_RE )
2507                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2508             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2509             s = PL_bufend;
2510         }
2511         else {
2512             s = scan_const(PL_bufptr);
2513             if (*s == '\\')
2514                 PL_lex_state = LEX_INTERPCASEMOD;
2515             else
2516                 PL_lex_state = LEX_INTERPSTART;
2517         }
2518
2519         if (s != PL_bufptr) {
2520             PL_nextval[PL_nexttoke] = yylval;
2521             PL_expect = XTERM;
2522             force_next(THING);
2523             if (PL_lex_starts++) {
2524                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2525                 if (!PL_lex_casemods && PL_lex_inpat)
2526                     OPERATOR(',');
2527                 else
2528                     Aop(OP_CONCAT);
2529             }
2530             else {
2531                 PL_bufptr = s;
2532                 return yylex();
2533             }
2534         }
2535
2536         return yylex();
2537     case LEX_FORMLINE:
2538         PL_lex_state = LEX_NORMAL;
2539         s = scan_formline(PL_bufptr);
2540         if (!PL_lex_formbrack)
2541             goto rightbracket;
2542         OPERATOR(';');
2543     }
2544
2545     s = PL_bufptr;
2546     PL_oldoldbufptr = PL_oldbufptr;
2547     PL_oldbufptr = s;
2548     DEBUG_T( {
2549         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2550                       exp_name[PL_expect], s);
2551     } );
2552
2553   retry:
2554     switch (*s) {
2555     default:
2556         if (isIDFIRST_lazy_if(s,UTF))
2557             goto keylookup;
2558         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2559     case 4:
2560     case 26:
2561         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2562     case 0:
2563         if (!PL_rsfp) {
2564             PL_last_uni = 0;
2565             PL_last_lop = 0;
2566             if (PL_lex_brackets) {
2567                 if (PL_lex_formbrack)
2568                     yyerror("Format not terminated");
2569                 else
2570                     yyerror("Missing right curly or square bracket");
2571             }
2572             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2573                         "### Tokener got EOF\n");
2574             } );
2575             TOKEN(0);
2576         }
2577         if (s++ < PL_bufend)
2578             goto retry;                 /* ignore stray nulls */
2579         PL_last_uni = 0;
2580         PL_last_lop = 0;
2581         if (!PL_in_eval && !PL_preambled) {
2582             PL_preambled = TRUE;
2583             sv_setpv(PL_linestr,incl_perldb());
2584             if (SvCUR(PL_linestr))
2585                 sv_catpvn(PL_linestr,";", 1);
2586             if (PL_preambleav){
2587                 while(AvFILLp(PL_preambleav) >= 0) {
2588                     SV *tmpsv = av_shift(PL_preambleav);
2589                     sv_catsv(PL_linestr, tmpsv);
2590                     sv_catpvn(PL_linestr, ";", 1);
2591                     sv_free(tmpsv);
2592                 }
2593                 sv_free((SV*)PL_preambleav);
2594                 PL_preambleav = NULL;
2595             }
2596             if (PL_minus_n || PL_minus_p) {
2597                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2598                 if (PL_minus_l)
2599                     sv_catpv(PL_linestr,"chomp;");
2600                 if (PL_minus_a) {
2601                     if (PL_minus_F) {
2602                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2603                              || *PL_splitstr == '"')
2604                               && strchr(PL_splitstr + 1, *PL_splitstr))
2605                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2606                         else {
2607                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2608                                bytes can be used as quoting characters.  :-) */
2609                             /* The count here deliberately includes the NUL
2610                                that terminates the C string constant.  This
2611                                embeds the opening NUL into the string.  */
2612                             const char *splits = PL_splitstr;
2613                             sv_catpvn(PL_linestr, "our @F=split(q", 15);
2614                             do {
2615                                 /* Need to \ \s  */
2616                                 if (*splits == '\\')
2617                                     sv_catpvn(PL_linestr, splits, 1);
2618                                 sv_catpvn(PL_linestr, splits, 1);
2619                             } while (*splits++);
2620                             /* This loop will embed the trailing NUL of
2621                                PL_linestr as the last thing it does before
2622                                terminating.  */
2623                             sv_catpvn(PL_linestr, ");", 2);
2624                         }
2625                     }
2626                     else
2627                         sv_catpv(PL_linestr,"our @F=split(' ');");
2628                 }
2629             }
2630             sv_catpvn(PL_linestr, "\n", 1);
2631             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2632             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2633             PL_last_lop = PL_last_uni = Nullch;
2634             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2635                 SV *sv = NEWSV(85,0);
2636
2637                 sv_upgrade(sv, SVt_PVMG);
2638                 sv_setsv(sv,PL_linestr);
2639                 (void)SvIOK_on(sv);
2640                 SvIV_set(sv, 0);
2641                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2642             }
2643             goto retry;
2644         }
2645         do {
2646             bof = PL_rsfp ? TRUE : FALSE;
2647             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2648               fake_eof:
2649                 if (PL_rsfp) {
2650                     if (PL_preprocess && !PL_in_eval)
2651                         (void)PerlProc_pclose(PL_rsfp);
2652                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2653                         PerlIO_clearerr(PL_rsfp);
2654                     else
2655                         (void)PerlIO_close(PL_rsfp);
2656                     PL_rsfp = Nullfp;
2657                     PL_doextract = FALSE;
2658                 }
2659                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2660                     sv_setpv(PL_linestr,PL_minus_p
2661                              ? ";}continue{print;}" : ";}");
2662                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2663                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2664                     PL_last_lop = PL_last_uni = Nullch;
2665                     PL_minus_n = PL_minus_p = 0;
2666                     goto retry;
2667                 }
2668                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2669                 PL_last_lop = PL_last_uni = Nullch;
2670                 sv_setpvn(PL_linestr,"",0);
2671                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2672             }
2673             /* If it looks like the start of a BOM or raw UTF-16,
2674              * check if it in fact is. */
2675             else if (bof &&
2676                      (*s == 0 ||
2677                       *(U8*)s == 0xEF ||
2678                       *(U8*)s >= 0xFE ||
2679                       s[1] == 0)) {
2680 #ifdef PERLIO_IS_STDIO
2681 #  ifdef __GNU_LIBRARY__
2682 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2683 #      define FTELL_FOR_PIPE_IS_BROKEN
2684 #    endif
2685 #  else
2686 #    ifdef __GLIBC__
2687 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2688 #        define FTELL_FOR_PIPE_IS_BROKEN
2689 #      endif
2690 #    endif
2691 #  endif
2692 #endif
2693 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2694                 /* This loses the possibility to detect the bof
2695                  * situation on perl -P when the libc5 is being used.
2696                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2697                  */
2698                 if (!PL_preprocess)
2699                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2700 #else
2701                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2702 #endif
2703                 if (bof) {
2704                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2705                     s = swallow_bom((U8*)s);
2706                 }
2707             }
2708             if (PL_doextract) {
2709                 /* Incest with pod. */
2710                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2711                     sv_setpvn(PL_linestr, "", 0);
2712                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2713                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2714                     PL_last_lop = PL_last_uni = Nullch;
2715                     PL_doextract = FALSE;
2716                 }
2717             }
2718             incline(s);
2719         } while (PL_doextract);
2720         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2721         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2722             SV *sv = NEWSV(85,0);
2723
2724             sv_upgrade(sv, SVt_PVMG);
2725             sv_setsv(sv,PL_linestr);
2726             (void)SvIOK_on(sv);
2727             SvIV_set(sv, 0);
2728             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2729         }
2730         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2731         PL_last_lop = PL_last_uni = Nullch;
2732         if (CopLINE(PL_curcop) == 1) {
2733             while (s < PL_bufend && isSPACE(*s))
2734                 s++;
2735             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2736                 s++;
2737             d = Nullch;
2738             if (!PL_in_eval) {
2739                 if (*s == '#' && *(s+1) == '!')
2740                     d = s + 2;
2741 #ifdef ALTERNATE_SHEBANG
2742                 else {
2743                     static char const as[] = ALTERNATE_SHEBANG;
2744                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2745                         d = s + (sizeof(as) - 1);
2746                 }
2747 #endif /* ALTERNATE_SHEBANG */
2748             }
2749             if (d) {
2750                 char *ipath;
2751                 char *ipathend;
2752
2753                 while (isSPACE(*d))
2754                     d++;
2755                 ipath = d;
2756                 while (*d && !isSPACE(*d))
2757                     d++;
2758                 ipathend = d;
2759
2760 #ifdef ARG_ZERO_IS_SCRIPT
2761                 if (ipathend > ipath) {
2762                     /*
2763                      * HP-UX (at least) sets argv[0] to the script name,
2764                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2765                      * at least, set argv[0] to the basename of the Perl
2766                      * interpreter. So, having found "#!", we'll set it right.
2767                      */
2768                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2769                     assert(SvPOK(x) || SvGMAGICAL(x));
2770                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2771                         sv_setpvn(x, ipath, ipathend - ipath);
2772                         SvSETMAGIC(x);
2773                     }
2774                     else {
2775                         STRLEN blen;
2776                         STRLEN llen;
2777                         const char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2778                         const char *lstart = SvPV(x,llen);
2779                         if (llen < blen) {
2780                             bstart += blen - llen;
2781                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2782                                 sv_setpvn(x, ipath, ipathend - ipath);
2783                                 SvSETMAGIC(x);
2784                             }
2785                         }
2786                     }
2787                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2788                 }
2789 #endif /* ARG_ZERO_IS_SCRIPT */
2790
2791                 /*
2792                  * Look for options.
2793                  */
2794                 d = instr(s,"perl -");
2795                 if (!d) {
2796                     d = instr(s,"perl");
2797 #if defined(DOSISH)
2798                     /* avoid getting into infinite loops when shebang
2799                      * line contains "Perl" rather than "perl" */
2800                     if (!d) {
2801                         for (d = ipathend-4; d >= ipath; --d) {
2802                             if ((*d == 'p' || *d == 'P')
2803                                 && !ibcmp(d, "perl", 4))
2804                             {
2805                                 break;
2806                             }
2807                         }
2808                         if (d < ipath)
2809                             d = Nullch;
2810                     }
2811 #endif
2812                 }
2813 #ifdef ALTERNATE_SHEBANG
2814                 /*
2815                  * If the ALTERNATE_SHEBANG on this system starts with a
2816                  * character that can be part of a Perl expression, then if
2817                  * we see it but not "perl", we're probably looking at the
2818                  * start of Perl code, not a request to hand off to some
2819                  * other interpreter.  Similarly, if "perl" is there, but
2820                  * not in the first 'word' of the line, we assume the line
2821                  * contains the start of the Perl program.
2822                  */
2823                 if (d && *s != '#') {
2824                     const char *c = ipath;
2825                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2826                         c++;
2827                     if (c < d)
2828                         d = Nullch;     /* "perl" not in first word; ignore */
2829                     else
2830                         *s = '#';       /* Don't try to parse shebang line */
2831                 }
2832 #endif /* ALTERNATE_SHEBANG */
2833 #ifndef MACOS_TRADITIONAL
2834                 if (!d &&
2835                     *s == '#' &&
2836                     ipathend > ipath &&
2837                     !PL_minus_c &&
2838                     !instr(s,"indir") &&
2839                     instr(PL_origargv[0],"perl"))
2840                 {
2841                     dVAR;
2842                     char **newargv;
2843
2844                     *ipathend = '\0';
2845                     s = ipathend + 1;
2846                     while (s < PL_bufend && isSPACE(*s))
2847                         s++;
2848                     if (s < PL_bufend) {
2849                         Newz(899,newargv,PL_origargc+3,char*);
2850                         newargv[1] = s;
2851                         while (s < PL_bufend && !isSPACE(*s))
2852                             s++;
2853                         *s = '\0';
2854                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2855                     }
2856                     else
2857                         newargv = PL_origargv;
2858                     newargv[0] = ipath;
2859                     PERL_FPU_PRE_EXEC
2860                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2861                     PERL_FPU_POST_EXEC
2862                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2863                 }
2864 #endif
2865                 if (d) {
2866                     const U32 oldpdb = PL_perldb;
2867                     const bool oldn = PL_minus_n;
2868                     const bool oldp = PL_minus_p;
2869
2870                     while (*d && !isSPACE(*d)) d++;
2871                     while (SPACE_OR_TAB(*d)) d++;
2872
2873                     if (*d++ == '-') {
2874                         const bool switches_done = PL_doswitches;
2875                         do {
2876                             if (*d == 'M' || *d == 'm' || *d == 'C') {
2877                                 const char *m = d;
2878                                 while (*d && !isSPACE(*d)) d++;
2879                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2880                                       (int)(d - m), m);
2881                             }
2882                             d = moreswitches(d);
2883                         } while (d);
2884                         if (PL_doswitches && !switches_done) {
2885                             int argc = PL_origargc;
2886                             char **argv = PL_origargv;
2887                             do {
2888                                 argc--,argv++;
2889                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2890                             init_argv_symbols(argc,argv);
2891                         }
2892                         if ((PERLDB_LINE && !oldpdb) ||
2893                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2894                               /* if we have already added "LINE: while (<>) {",
2895                                  we must not do it again */
2896                         {
2897                             sv_setpvn(PL_linestr, "", 0);
2898                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2899                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2900                             PL_last_lop = PL_last_uni = Nullch;
2901                             PL_preambled = FALSE;
2902                             if (PERLDB_LINE)
2903                                 (void)gv_fetchfile(PL_origfilename);
2904                             goto retry;
2905                         }
2906                         if (PL_doswitches && !switches_done) {
2907                             int argc = PL_origargc;
2908                             char **argv = PL_origargv;
2909                             do {
2910                                 argc--,argv++;
2911                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2912                             init_argv_symbols(argc,argv);
2913                         }
2914                     }
2915                 }
2916             }
2917         }
2918         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2919             PL_bufptr = s;
2920             PL_lex_state = LEX_FORMLINE;
2921             return yylex();
2922         }
2923         goto retry;
2924     case '\r':
2925 #ifdef PERL_STRICT_CR
2926         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2927         Perl_croak(aTHX_
2928       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2929 #endif
2930     case ' ': case '\t': case '\f': case 013:
2931 #ifdef MACOS_TRADITIONAL
2932     case '\312':
2933 #endif
2934         s++;
2935         goto retry;
2936     case '#':
2937     case '\n':
2938         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2939             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2940                 /* handle eval qq[#line 1 "foo"\n ...] */
2941                 CopLINE_dec(PL_curcop);
2942                 incline(s);
2943             }
2944             d = PL_bufend;
2945             while (s < d && *s != '\n')
2946                 s++;
2947             if (s < d)
2948                 s++;
2949             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2950               Perl_croak(aTHX_ "panic: input overflow");
2951             incline(s);
2952             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2953                 PL_bufptr = s;
2954                 PL_lex_state = LEX_FORMLINE;
2955                 return yylex();
2956             }
2957         }
2958         else {
2959             *s = '\0';
2960             PL_bufend = s;
2961         }
2962         goto retry;
2963     case '-':
2964         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2965             I32 ftst = 0;
2966
2967             s++;
2968             PL_bufptr = s;
2969             tmp = *s++;
2970
2971             while (s < PL_bufend && SPACE_OR_TAB(*s))
2972                 s++;
2973
2974             if (strnEQ(s,"=>",2)) {
2975                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2976                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2977                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2978                 } );
2979                 OPERATOR('-');          /* unary minus */
2980             }
2981             PL_last_uni = PL_oldbufptr;
2982             switch (tmp) {
2983             case 'r': ftst = OP_FTEREAD;        break;
2984             case 'w': ftst = OP_FTEWRITE;       break;
2985             case 'x': ftst = OP_FTEEXEC;        break;
2986             case 'o': ftst = OP_FTEOWNED;       break;
2987             case 'R': ftst = OP_FTRREAD;        break;
2988             case 'W': ftst = OP_FTRWRITE;       break;
2989             case 'X': ftst = OP_FTREXEC;        break;
2990             case 'O': ftst = OP_FTROWNED;       break;
2991             case 'e': ftst = OP_FTIS;           break;
2992             case 'z': ftst = OP_FTZERO;         break;
2993             case 's': ftst = OP_FTSIZE;         break;
2994             case 'f': ftst = OP_FTFILE;         break;
2995             case 'd': ftst = OP_FTDIR;          break;
2996             case 'l': ftst = OP_FTLINK;         break;
2997             case 'p': ftst = OP_FTPIPE;         break;
2998             case 'S': ftst = OP_FTSOCK;         break;
2999             case 'u': ftst = OP_FTSUID;         break;
3000             case 'g': ftst = OP_FTSGID;         break;
3001             case 'k': ftst = OP_FTSVTX;         break;
3002             case 'b': ftst = OP_FTBLK;          break;
3003             case 'c': ftst = OP_FTCHR;          break;
3004             case 't': ftst = OP_FTTTY;          break;
3005             case 'T': ftst = OP_FTTEXT;         break;
3006             case 'B': ftst = OP_FTBINARY;       break;
3007             case 'M': case 'A': case 'C':
3008                 gv_fetchpv("\024",TRUE, SVt_PV);
3009                 switch (tmp) {
3010                 case 'M': ftst = OP_FTMTIME;    break;
3011                 case 'A': ftst = OP_FTATIME;    break;
3012                 case 'C': ftst = OP_FTCTIME;    break;
3013                 default:                        break;
3014                 }
3015                 break;
3016             default:
3017                 break;
3018             }
3019             if (ftst) {
3020                 PL_last_lop_op = (OPCODE)ftst;
3021                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3022                         "### Saw file test %c\n", (int)ftst);
3023                 } );
3024                 FTST(ftst);
3025             }
3026             else {
3027                 /* Assume it was a minus followed by a one-letter named
3028                  * subroutine call (or a -bareword), then. */
3029                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3030                         "### '-%c' looked like a file test but was not\n",
3031                         (int) tmp);
3032                 } );
3033                 s = --PL_bufptr;
3034             }
3035         }
3036         tmp = *s++;
3037         if (*s == tmp) {
3038             s++;
3039             if (PL_expect == XOPERATOR)
3040                 TERM(POSTDEC);
3041             else
3042                 OPERATOR(PREDEC);
3043         }
3044         else if (*s == '>') {
3045             s++;
3046             s = skipspace(s);
3047             if (isIDFIRST_lazy_if(s,UTF)) {
3048                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3049                 TOKEN(ARROW);
3050             }
3051             else if (*s == '$')
3052                 OPERATOR(ARROW);
3053             else
3054                 TERM(ARROW);
3055         }
3056         if (PL_expect == XOPERATOR)
3057             Aop(OP_SUBTRACT);
3058         else {
3059             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3060                 check_uni();
3061             OPERATOR('-');              /* unary minus */
3062         }
3063
3064     case '+':
3065         tmp = *s++;
3066         if (*s == tmp) {
3067             s++;
3068             if (PL_expect == XOPERATOR)
3069                 TERM(POSTINC);
3070             else
3071                 OPERATOR(PREINC);
3072         }
3073         if (PL_expect == XOPERATOR)
3074             Aop(OP_ADD);
3075         else {
3076             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3077                 check_uni();
3078             OPERATOR('+');
3079         }
3080
3081     case '*':
3082         if (PL_expect != XOPERATOR) {
3083             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3084             PL_expect = XOPERATOR;
3085             force_ident(PL_tokenbuf, '*');
3086             if (!*PL_tokenbuf)
3087                 PREREF('*');
3088             TERM('*');
3089         }
3090         s++;
3091         if (*s == '*') {
3092             s++;
3093             PWop(OP_POW);
3094         }
3095         Mop(OP_MULTIPLY);
3096
3097     case '%':
3098         if (PL_expect == XOPERATOR) {
3099             ++s;
3100             Mop(OP_MODULO);
3101         }
3102         PL_tokenbuf[0] = '%';
3103         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3104         if (!PL_tokenbuf[1]) {
3105             PREREF('%');
3106         }
3107         PL_pending_ident = '%';
3108         TERM('%');
3109
3110     case '^':
3111         s++;
3112         BOop(OP_BIT_XOR);
3113     case '[':
3114         PL_lex_brackets++;
3115         /* FALL THROUGH */
3116     case '~':
3117     case ',':
3118         tmp = *s++;
3119         OPERATOR(tmp);
3120     case ':':
3121         if (s[1] == ':') {
3122             len = 0;
3123             goto just_a_word;
3124         }
3125         s++;
3126         switch (PL_expect) {
3127             OP *attrs;
3128         case XOPERATOR:
3129             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3130                 break;
3131             PL_bufptr = s;      /* update in case we back off */
3132             goto grabattrs;
3133         case XATTRBLOCK:
3134             PL_expect = XBLOCK;
3135             goto grabattrs;
3136         case XATTRTERM:
3137             PL_expect = XTERMBLOCK;
3138          grabattrs:
3139             s = skipspace(s);
3140             attrs = Nullop;
3141             while (isIDFIRST_lazy_if(s,UTF)) {
3142                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3143                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3144                     if (tmp < 0) tmp = -tmp;
3145                     switch (tmp) {
3146                     case KEY_or:
3147                     case KEY_and:
3148                     case KEY_err:
3149                     case KEY_for:
3150                     case KEY_unless:
3151                     case KEY_if:
3152                     case KEY_while:
3153                     case KEY_until:
3154                         goto got_attrs;
3155                     default:
3156                         break;
3157                     }
3158                 }
3159                 if (*d == '(') {
3160                     d = scan_str(d,TRUE,TRUE);
3161                     if (!d) {
3162                         /* MUST advance bufptr here to avoid bogus
3163                            "at end of line" context messages from yyerror().
3164                          */
3165                         PL_bufptr = s + len;
3166                         yyerror("Unterminated attribute parameter in attribute list");
3167                         if (attrs)
3168                             op_free(attrs);
3169                         return REPORT(0);       /* EOF indicator */
3170                     }
3171                 }
3172                 if (PL_lex_stuff) {
3173                     SV *sv = newSVpvn(s, len);
3174                     sv_catsv(sv, PL_lex_stuff);
3175                     attrs = append_elem(OP_LIST, attrs,
3176                                         newSVOP(OP_CONST, 0, sv));
3177                     SvREFCNT_dec(PL_lex_stuff);
3178                     PL_lex_stuff = Nullsv;
3179                 }
3180                 else {
3181                     if (len == 6 && strnEQ(s, "unique", len)) {
3182                         if (PL_in_my == KEY_our)
3183 #ifdef USE_ITHREADS
3184                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3185 #else
3186                             ; /* skip to avoid loading attributes.pm */
3187 #endif
3188                         else
3189                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3190                     }
3191
3192                     /* NOTE: any CV attrs applied here need to be part of
3193                        the CVf_BUILTIN_ATTRS define in cv.h! */
3194                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3195                         CvLVALUE_on(PL_compcv);
3196                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3197                         CvLOCKED_on(PL_compcv);
3198                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3199                         CvMETHOD_on(PL_compcv);
3200                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3201                         CvASSERTION_on(PL_compcv);
3202                     /* After we've set the flags, it could be argued that
3203                        we don't need to do the attributes.pm-based setting
3204                        process, and shouldn't bother appending recognized
3205                        flags.  To experiment with that, uncomment the
3206                        following "else".  (Note that's already been
3207                        uncommented.  That keeps the above-applied built-in
3208                        attributes from being intercepted (and possibly
3209                        rejected) by a package's attribute routines, but is
3210                        justified by the performance win for the common case
3211                        of applying only built-in attributes.) */
3212                     else
3213                         attrs = append_elem(OP_LIST, attrs,
3214                                             newSVOP(OP_CONST, 0,
3215                                                     newSVpvn(s, len)));
3216                 }
3217                 s = skipspace(d);
3218                 if (*s == ':' && s[1] != ':')
3219                     s = skipspace(s+1);
3220                 else if (s == d)
3221                     break;      /* require real whitespace or :'s */
3222             }
3223             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3224             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3225                 const char q = ((*s == '\'') ? '"' : '\'');
3226                 /* If here for an expression, and parsed no attrs, back off. */
3227                 if (tmp == '=' && !attrs) {
3228                     s = PL_bufptr;
3229                     break;
3230                 }
3231                 /* MUST advance bufptr here to avoid bogus "at end of line"
3232                    context messages from yyerror().
3233                  */
3234                 PL_bufptr = s;
3235                 if (!*s)
3236                     yyerror("Unterminated attribute list");
3237                 else
3238                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3239                                       q, *s, q));
3240                 if (attrs)
3241                     op_free(attrs);
3242                 OPERATOR(':');
3243             }
3244         got_attrs:
3245             if (attrs) {
3246                 PL_nextval[PL_nexttoke].opval = attrs;
3247                 force_next(THING);
3248             }
3249             TOKEN(COLONATTR);
3250         }
3251         OPERATOR(':');
3252     case '(':
3253         s++;
3254         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3255             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3256         else
3257             PL_expect = XTERM;
3258         s = skipspace(s);
3259         TOKEN('(');
3260     case ';':
3261         CLINE;
3262         tmp = *s++;
3263         OPERATOR(tmp);
3264     case ')':
3265         tmp = *s++;
3266         s = skipspace(s);
3267         if (*s == '{')
3268             PREBLOCK(tmp);
3269         TERM(tmp);
3270     case ']':
3271         s++;
3272         if (PL_lex_brackets <= 0)
3273             yyerror("Unmatched right square bracket");
3274         else
3275             --PL_lex_brackets;
3276         if (PL_lex_state == LEX_INTERPNORMAL) {
3277             if (PL_lex_brackets == 0) {
3278                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3279                     PL_lex_state = LEX_INTERPEND;
3280             }
3281         }
3282         TERM(']');
3283     case '{':
3284       leftbracket:
3285         s++;
3286         if (PL_lex_brackets > 100) {
3287             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3288         }
3289         switch (PL_expect) {
3290         case XTERM:
3291             if (PL_lex_formbrack) {
3292                 s--;
3293                 PRETERMBLOCK(DO);
3294             }
3295             if (PL_oldoldbufptr == PL_last_lop)
3296                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3297             else
3298                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3299             OPERATOR(HASHBRACK);
3300         case XOPERATOR:
3301             while (s < PL_bufend && SPACE_OR_TAB(*s))
3302                 s++;
3303             d = s;
3304             PL_tokenbuf[0] = '\0';
3305             if (d < PL_bufend && *d == '-') {
3306                 PL_tokenbuf[0] = '-';
3307                 d++;
3308                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3309                     d++;
3310             }
3311             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3312                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3313                               FALSE, &len);
3314                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3315                     d++;
3316                 if (*d == '}') {
3317                     const char minus = (PL_tokenbuf[0] == '-');
3318                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3319                     if (minus)
3320                         force_next('-');
3321                 }
3322             }
3323             /* FALL THROUGH */
3324         case XATTRBLOCK:
3325         case XBLOCK:
3326             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3327             PL_expect = XSTATE;
3328             break;
3329         case XATTRTERM:
3330         case XTERMBLOCK:
3331             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3332             PL_expect = XSTATE;
3333             break;
3334         default: {
3335                 const char *t;
3336                 if (PL_oldoldbufptr == PL_last_lop)
3337                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3338                 else
3339                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3340                 s = skipspace(s);
3341                 if (*s == '}') {
3342                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3343                         PL_expect = XTERM;
3344                         /* This hack is to get the ${} in the message. */
3345                         PL_bufptr = s+1;
3346                         yyerror("syntax error");
3347                         break;
3348                     }
3349                     OPERATOR(HASHBRACK);
3350                 }
3351                 /* This hack serves to disambiguate a pair of curlies
3352                  * as being a block or an anon hash.  Normally, expectation
3353                  * determines that, but in cases where we're not in a
3354                  * position to expect anything in particular (like inside
3355                  * eval"") we have to resolve the ambiguity.  This code
3356                  * covers the case where the first term in the curlies is a
3357                  * quoted string.  Most other cases need to be explicitly
3358                  * disambiguated by prepending a "+" before the opening
3359                  * curly in order to force resolution as an anon hash.
3360                  *
3361                  * XXX should probably propagate the outer expectation
3362                  * into eval"" to rely less on this hack, but that could
3363                  * potentially break current behavior of eval"".
3364                  * GSAR 97-07-21
3365                  */
3366                 t = s;
3367                 if (*s == '\'' || *s == '"' || *s == '`') {
3368                     /* common case: get past first string, handling escapes */
3369                     for (t++; t < PL_bufend && *t != *s;)
3370                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3371                             t++;
3372                     t++;
3373                 }
3374                 else if (*s == 'q') {
3375                     if (++t < PL_bufend
3376                         && (!isALNUM(*t)
3377                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3378                                 && !isALNUM(*t))))
3379                     {
3380                         /* skip q//-like construct */
3381                         const char *tmps;
3382                         char open, close, term;
3383                         I32 brackets = 1;
3384
3385                         while (t < PL_bufend && isSPACE(*t))
3386                             t++;
3387                         /* check for q => */
3388                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3389                             OPERATOR(HASHBRACK);
3390                         }
3391                         term = *t;
3392                         open = term;
3393                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3394                             term = tmps[5];
3395                         close = term;
3396                         if (open == close)
3397                             for (t++; t < PL_bufend; t++) {
3398                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3399                                     t++;
3400                                 else if (*t == open)
3401                                     break;
3402                             }
3403                         else {
3404                             for (t++; t < PL_bufend; t++) {
3405                                 if (*t == '\\' && t+1 < PL_bufend)
3406                                     t++;
3407                                 else if (*t == close && --brackets <= 0)
3408                                     break;
3409                                 else if (*t == open)
3410                                     brackets++;
3411                             }
3412                         }
3413                         t++;
3414                     }
3415                     else
3416                         /* skip plain q word */
3417                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3418                              t += UTF8SKIP(t);
3419                 }
3420                 else if (isALNUM_lazy_if(t,UTF)) {
3421                     t += UTF8SKIP(t);
3422                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3423                          t += UTF8SKIP(t);
3424                 }
3425                 while (t < PL_bufend && isSPACE(*t))
3426                     t++;
3427                 /* if comma follows first term, call it an anon hash */
3428                 /* XXX it could be a comma expression with loop modifiers */
3429                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3430                                    || (*t == '=' && t[1] == '>')))
3431                     OPERATOR(HASHBRACK);
3432                 if (PL_expect == XREF)
3433                     PL_expect = XTERM;
3434                 else {
3435                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3436                     PL_expect = XSTATE;
3437                 }
3438             }
3439             break;
3440         }
3441         yylval.ival = CopLINE(PL_curcop);
3442         if (isSPACE(*s) || *s == '#')
3443             PL_copline = NOLINE;   /* invalidate current command line number */
3444         TOKEN('{');
3445     case '}':
3446       rightbracket:
3447         s++;
3448         if (PL_lex_brackets <= 0)
3449             yyerror("Unmatched right curly bracket");
3450         else
3451             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3452         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3453             PL_lex_formbrack = 0;
3454         if (PL_lex_state == LEX_INTERPNORMAL) {
3455             if (PL_lex_brackets == 0) {
3456                 if (PL_expect & XFAKEBRACK) {
3457                     PL_expect &= XENUMMASK;
3458                     PL_lex_state = LEX_INTERPEND;
3459                     PL_bufptr = s;
3460                     return yylex();     /* ignore fake brackets */
3461                 }
3462                 if (*s == '-' && s[1] == '>')
3463                     PL_lex_state = LEX_INTERPENDMAYBE;
3464                 else if (*s != '[' && *s != '{')
3465                     PL_lex_state = LEX_INTERPEND;
3466             }
3467         }
3468         if (PL_expect & XFAKEBRACK) {
3469             PL_expect &= XENUMMASK;
3470             PL_bufptr = s;
3471             return yylex();             /* ignore fake brackets */
3472         }
3473         force_next('}');
3474         TOKEN(';');
3475     case '&':
3476         s++;
3477         tmp = *s++;
3478         if (tmp == '&')
3479             AOPERATOR(ANDAND);
3480         s--;
3481         if (PL_expect == XOPERATOR) {
3482             if (ckWARN(WARN_SEMICOLON)
3483                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3484             {
3485                 CopLINE_dec(PL_curcop);
3486                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3487                 CopLINE_inc(PL_curcop);
3488             }
3489             BAop(OP_BIT_AND);
3490         }
3491
3492         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3493         if (*PL_tokenbuf) {
3494             PL_expect = XOPERATOR;
3495             force_ident(PL_tokenbuf, '&');
3496         }
3497         else
3498             PREREF('&');
3499         yylval.ival = (OPpENTERSUB_AMPER<<8);
3500         TERM('&');
3501
3502     case '|':
3503         s++;
3504         tmp = *s++;
3505         if (tmp == '|')
3506             AOPERATOR(OROR);
3507         s--;
3508         BOop(OP_BIT_OR);
3509     case '=':
3510         s++;
3511         tmp = *s++;
3512         if (tmp == '=')
3513             Eop(OP_EQ);
3514         if (tmp == '>')
3515             OPERATOR(',');
3516         if (tmp == '~')
3517             PMop(OP_MATCH);
3518         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3519             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3520         s--;
3521         if (PL_expect == XSTATE && isALPHA(tmp) &&
3522                 (s == PL_linestart+1 || s[-2] == '\n') )
3523         {
3524             if (PL_in_eval && !PL_rsfp) {
3525                 d = PL_bufend;
3526                 while (s < d) {
3527                     if (*s++ == '\n') {
3528                         incline(s);
3529                         if (strnEQ(s,"=cut",4)) {
3530                             s = strchr(s,'\n');
3531                             if (s)
3532                                 s++;
3533                             else
3534                                 s = d;
3535                             incline(s);
3536                             goto retry;
3537                         }
3538                     }
3539                 }
3540                 goto retry;
3541             }
3542             s = PL_bufend;
3543             PL_doextract = TRUE;
3544             goto retry;
3545         }
3546         if (PL_lex_brackets < PL_lex_formbrack) {
3547             const char *t;
3548 #ifdef PERL_STRICT_CR
3549             for (t = s; SPACE_OR_TAB(*t); t++) ;
3550 #else
3551             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3552 #endif
3553             if (*t == '\n' || *t == '#') {
3554                 s--;
3555                 PL_expect = XBLOCK;
3556                 goto leftbracket;
3557             }
3558         }
3559         yylval.ival = 0;
3560         OPERATOR(ASSIGNOP);
3561     case '!':
3562         s++;
3563         tmp = *s++;
3564         if (tmp == '=') {
3565             /* was this !=~ where !~ was meant?
3566              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3567
3568             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3569                 const char *t = s+1;
3570
3571                 while (t < PL_bufend && isSPACE(*t))
3572                     ++t;
3573
3574                 if (*t == '/' || *t == '?' ||
3575                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3576                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3577                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3578                                 "!=~ should be !~");
3579             }
3580             Eop(OP_NE);
3581         }
3582         if (tmp == '~')
3583             PMop(OP_NOT);
3584         s--;
3585         OPERATOR('!');
3586     case '<':
3587         if (PL_expect != XOPERATOR) {
3588             if (s[1] != '<' && !strchr(s,'>'))
3589                 check_uni();
3590             if (s[1] == '<')
3591                 s = scan_heredoc(s);
3592             else
3593                 s = scan_inputsymbol(s);
3594             TERM(sublex_start());
3595         }
3596         s++;
3597         tmp = *s++;
3598         if (tmp == '<')
3599             SHop(OP_LEFT_SHIFT);
3600         if (tmp == '=') {
3601             tmp = *s++;
3602             if (tmp == '>')
3603                 Eop(OP_NCMP);
3604             s--;
3605             Rop(OP_LE);
3606         }
3607         s--;
3608         Rop(OP_LT);
3609     case '>':
3610         s++;
3611         tmp = *s++;
3612         if (tmp == '>')
3613             SHop(OP_RIGHT_SHIFT);
3614         if (tmp == '=')
3615             Rop(OP_GE);
3616         s--;
3617         Rop(OP_GT);
3618
3619     case '$':
3620         CLINE;
3621
3622         if (PL_expect == XOPERATOR) {
3623             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3624                 PL_expect = XTERM;
3625                 depcom();
3626                 return REPORT(','); /* grandfather non-comma-format format */
3627             }
3628         }
3629
3630         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3631             PL_tokenbuf[0] = '@';
3632             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3633                            sizeof PL_tokenbuf - 1, FALSE);
3634             if (PL_expect == XOPERATOR)
3635                 no_op("Array length", s);
3636             if (!PL_tokenbuf[1])
3637                 PREREF(DOLSHARP);
3638             PL_expect = XOPERATOR;
3639             PL_pending_ident = '#';
3640             TOKEN(DOLSHARP);
3641         }
3642
3643         PL_tokenbuf[0] = '$';
3644         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3645                        sizeof PL_tokenbuf - 1, FALSE);
3646         if (PL_expect == XOPERATOR)
3647             no_op("Scalar", s);
3648         if (!PL_tokenbuf[1]) {
3649             if (s == PL_bufend)
3650                 yyerror("Final $ should be \\$ or $name");
3651             PREREF('$');
3652         }
3653
3654         /* This kludge not intended to be bulletproof. */
3655         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3656             yylval.opval = newSVOP(OP_CONST, 0,
3657                                    newSViv(PL_compiling.cop_arybase));
3658             yylval.opval->op_private = OPpCONST_ARYBASE;
3659             TERM(THING);
3660         }
3661
3662         d = s;
3663         tmp = (I32)*s;
3664         if (PL_lex_state == LEX_NORMAL)
3665             s = skipspace(s);
3666
3667         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3668             char *t;
3669             if (*s == '[') {
3670                 PL_tokenbuf[0] = '@';
3671                 if (ckWARN(WARN_SYNTAX)) {
3672                     for(t = s + 1;
3673                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3674                         t++) ;
3675                     if (*t++ == ',') {
3676                         PL_bufptr = skipspace(PL_bufptr);
3677                         while (t < PL_bufend && *t != ']')
3678                             t++;
3679                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3680                                 "Multidimensional syntax %.*s not supported",
3681                                 (t - PL_bufptr) + 1, PL_bufptr);
3682                     }
3683                 }
3684             }
3685             else if (*s == '{') {
3686                 PL_tokenbuf[0] = '%';
3687                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3688                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3689                 {
3690                     char tmpbuf[sizeof PL_tokenbuf];
3691                     for (t++; isSPACE(*t); t++) ;
3692                     if (isIDFIRST_lazy_if(t,UTF)) {
3693                         STRLEN len;
3694                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3695                         for (; isSPACE(*t); t++) ;
3696                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3697                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3698                                 "You need to quote \"%s\"", tmpbuf);
3699                     }
3700                 }
3701             }
3702         }
3703
3704         PL_expect = XOPERATOR;
3705         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3706             const bool islop = (PL_last_lop == PL_oldoldbufptr);
3707             if (!islop || PL_last_lop_op == OP_GREPSTART)
3708                 PL_expect = XOPERATOR;
3709             else if (strchr("$@\"'`q", *s))
3710                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3711             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3712                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3713             else if (isIDFIRST_lazy_if(s,UTF)) {
3714                 char tmpbuf[sizeof PL_tokenbuf];
3715                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3716                 if ((tmp = keyword(tmpbuf, len))) {
3717                     /* binary operators exclude handle interpretations */
3718                     switch (tmp) {
3719                     case -KEY_x:
3720                     case -KEY_eq:
3721                     case -KEY_ne:
3722                     case -KEY_gt:
3723                     case -KEY_lt:
3724                     case -KEY_ge:
3725                     case -KEY_le:
3726                     case -KEY_cmp:
3727                         break;
3728                     default:
3729                         PL_expect = XTERM;      /* e.g. print $fh length() */
3730                         break;
3731                     }
3732                 }
3733                 else {
3734                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3735                 }
3736             }
3737             else if (isDIGIT(*s))
3738                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3739             else if (*s == '.' && isDIGIT(s[1]))
3740                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3741             else if ((*s == '?' || *s == '-' || *s == '+')
3742                      && !isSPACE(s[1]) && s[1] != '=')
3743                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3744             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3745                 PL_expect = XTERM;              /* e.g. print $fh /.../
3746                                                  XXX except DORDOR operator */
3747             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3748                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3749         }
3750         PL_pending_ident = '$';
3751         TOKEN('$');
3752
3753     case '@':
3754         if (PL_expect == XOPERATOR)
3755             no_op("Array", s);
3756         PL_tokenbuf[0] = '@';
3757         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3758         if (!PL_tokenbuf[1]) {
3759             PREREF('@');
3760         }
3761         if (PL_lex_state == LEX_NORMAL)
3762             s = skipspace(s);
3763         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3764             if (*s == '{')
3765                 PL_tokenbuf[0] = '%';
3766
3767             /* Warn about @ where they meant $. */
3768             if (ckWARN(WARN_SYNTAX)) {
3769                 if (*s == '[' || *s == '{') {
3770                     const char *t = s + 1;
3771                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3772                         t++;
3773                     if (*t == '}' || *t == ']') {
3774                         t++;
3775                         PL_bufptr = skipspace(PL_bufptr);
3776                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3777                             "Scalar value %.*s better written as $%.*s",
3778                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3779                     }
3780                 }
3781             }
3782         }
3783         PL_pending_ident = '@';
3784         TERM('@');
3785
3786      case '/':                  /* may be division, defined-or, or pattern */
3787         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3788             s += 2;
3789             AOPERATOR(DORDOR);
3790         }
3791      case '?':                  /* may either be conditional or pattern */
3792          if(PL_expect == XOPERATOR) {
3793              tmp = *s++;
3794              if(tmp == '?') {
3795                   OPERATOR('?');
3796              }
3797              else {
3798                  tmp = *s++;
3799                  if(tmp == '/') {
3800                      /* A // operator. */
3801                     AOPERATOR(DORDOR);
3802                  }
3803                  else {
3804                      s--;
3805                      Mop(OP_DIVIDE);
3806                  }
3807              }
3808          }
3809          else {
3810              /* Disable warning on "study /blah/" */
3811              if (PL_oldoldbufptr == PL_last_uni
3812               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3813                   || memNE(PL_last_uni, "study", 5)
3814                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3815               ))
3816                  check_uni();
3817              s = scan_pat(s,OP_MATCH);
3818              TERM(sublex_start());
3819          }
3820
3821     case '.':
3822         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3823 #ifdef PERL_STRICT_CR
3824             && s[1] == '\n'
3825 #else
3826             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3827 #endif
3828             && (s == PL_linestart || s[-1] == '\n') )
3829         {
3830             PL_lex_formbrack = 0;
3831             PL_expect = XSTATE;
3832             goto rightbracket;
3833         }
3834         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3835             tmp = *s++;
3836             if (*s == tmp) {
3837                 s++;
3838                 if (*s == tmp) {
3839                     s++;
3840                     yylval.ival = OPf_SPECIAL;
3841                 }
3842                 else
3843                     yylval.ival = 0;
3844                 OPERATOR(DOTDOT);
3845             }
3846             if (PL_expect != XOPERATOR)
3847                 check_uni();
3848             Aop(OP_CONCAT);
3849         }
3850         /* FALL THROUGH */
3851     case '0': case '1': case '2': case '3': case '4':
3852     case '5': case '6': case '7': case '8': case '9':
3853         s = scan_num(s, &yylval);
3854         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3855                     "### Saw number in '%s'\n", s);
3856         } );
3857         if (PL_expect == XOPERATOR)
3858             no_op("Number",s);
3859         TERM(THING);
3860
3861     case '\'':
3862         s = scan_str(s,FALSE,FALSE);
3863         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3864                     "### Saw string before '%s'\n", s);
3865         } );
3866         if (PL_expect == XOPERATOR) {
3867             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3868                 PL_expect = XTERM;
3869                 depcom();
3870                 return REPORT(','); /* grandfather non-comma-format format */
3871             }
3872             else
3873                 no_op("String",s);
3874         }
3875         if (!s)
3876             missingterm((char*)0);
3877         yylval.ival = OP_CONST;
3878         TERM(sublex_start());
3879
3880     case '"':
3881         s = scan_str(s,FALSE,FALSE);
3882         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3883                     "### Saw string before '%s'\n", s);
3884         } );
3885         if (PL_expect == XOPERATOR) {
3886             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3887                 PL_expect = XTERM;
3888                 depcom();
3889                 return REPORT(','); /* grandfather non-comma-format format */
3890             }
3891             else
3892                 no_op("String",s);
3893         }
3894         if (!s)
3895             missingterm((char*)0);
3896         yylval.ival = OP_CONST;
3897         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3898             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3899                 yylval.ival = OP_STRINGIFY;
3900                 break;
3901             }
3902         }
3903         TERM(sublex_start());
3904
3905     case '`':
3906         s = scan_str(s,FALSE,FALSE);
3907         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3908                     "### Saw backtick string before '%s'\n", s);
3909         } );
3910         if (PL_expect == XOPERATOR)
3911             no_op("Backticks",s);
3912         if (!s)
3913             missingterm((char*)0);
3914         yylval.ival = OP_BACKTICK;
3915         set_csh();
3916         TERM(sublex_start());
3917
3918     case '\\':
3919         s++;
3920         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3921             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3922                         *s, *s);
3923         if (PL_expect == XOPERATOR)
3924             no_op("Backslash",s);
3925         OPERATOR(REFGEN);
3926
3927     case 'v':
3928         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3929             char *start = s + 2;
3930             while (isDIGIT(*start) || *start == '_')
3931                 start++;
3932             if (*start == '.' && isDIGIT(start[1])) {
3933                 s = scan_num(s, &yylval);
3934                 TERM(THING);
3935             }
3936             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3937             else if (!isALPHA(*start) && (PL_expect == XTERM
3938                         || PL_expect == XREF || PL_expect == XSTATE
3939                         || PL_expect == XTERMORDORDOR)) {
3940                 const char c = *start;
3941                 GV *gv;
3942                 *start = '\0';
3943                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3944                 *start = c;
3945                 if (!gv) {
3946                     s = scan_num(s, &yylval);
3947                     TERM(THING);
3948                 }
3949             }
3950         }
3951         goto keylookup;
3952     case 'x':
3953         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3954             s++;
3955             Mop(OP_REPEAT);
3956         }
3957         goto keylookup;
3958
3959     case '_':
3960     case 'a': case 'A':
3961     case 'b': case 'B':
3962     case 'c': case 'C':
3963     case 'd': case 'D':
3964     case 'e': case 'E':
3965     case 'f': case 'F':
3966     case 'g': case 'G':
3967     case 'h': case 'H':
3968     case 'i': case 'I':
3969     case 'j': case 'J':
3970     case 'k': case 'K':
3971     case 'l': case 'L':
3972     case 'm': case 'M':
3973     case 'n': case 'N':
3974     case 'o': case 'O':
3975     case 'p': case 'P':
3976     case 'q': case 'Q':
3977     case 'r': case 'R':
3978     case 's': case 'S':
3979     case 't': case 'T':
3980     case 'u': case 'U':
3981               case 'V':
3982     case 'w': case 'W':
3983               case 'X':
3984     case 'y': case 'Y':
3985     case 'z': case 'Z':
3986
3987       keylookup: {
3988         orig_keyword = 0;
3989         gv = Nullgv;
3990         gvp = 0;
3991
3992         PL_bufptr = s;
3993         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3994
3995         /* Some keywords can be followed by any delimiter, including ':' */
3996         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3997                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3998                              (PL_tokenbuf[0] == 'q' &&
3999                               strchr("qwxr", PL_tokenbuf[1])))));
4000
4001         /* x::* is just a word, unless x is "CORE" */
4002         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4003             goto just_a_word;
4004
4005         d = s;
4006         while (d < PL_bufend && isSPACE(*d))
4007                 d++;    /* no comments skipped here, or s### is misparsed */
4008
4009         /* Is this a label? */
4010         if (!tmp && PL_expect == XSTATE
4011               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4012             s = d + 1;
4013             yylval.pval = savepv(PL_tokenbuf);
4014             CLINE;
4015             TOKEN(LABEL);
4016         }
4017
4018         /* Check for keywords */
4019         tmp = keyword(PL_tokenbuf, len);
4020
4021         /* Is this a word before a => operator? */
4022         if (*d == '=' && d[1] == '>') {
4023             CLINE;
4024             yylval.opval
4025                 = (OP*)newSVOP(OP_CONST, 0,
4026                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4027             yylval.opval->op_private = OPpCONST_BARE;
4028             TERM(WORD);
4029         }
4030
4031         if (tmp < 0) {                  /* second-class keyword? */
4032             GV *ogv = Nullgv;   /* override (winner) */
4033             GV *hgv = Nullgv;   /* hidden (loser) */
4034             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4035                 CV *cv;
4036                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4037                     (cv = GvCVu(gv)))
4038                 {
4039                     if (GvIMPORTED_CV(gv))
4040                         ogv = gv;
4041                     else if (! CvMETHOD(cv))
4042                         hgv = gv;
4043                 }
4044                 if (!ogv &&
4045                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4046                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4047                     GvCVu(gv) && GvIMPORTED_CV(gv))
4048                 {
4049                     ogv = gv;
4050                 }
4051             }
4052             if (ogv) {
4053                 orig_keyword = tmp;
4054                 tmp = 0;                /* overridden by import or by GLOBAL */
4055             }
4056             else if (gv && !gvp
4057                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4058                      && GvCVu(gv)
4059                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4060             {
4061                 tmp = 0;                /* any sub overrides "weak" keyword */
4062             }
4063             else if (gv && !gvp
4064                     && tmp == -KEY_err
4065                     && GvCVu(gv)
4066                     && PL_expect != XOPERATOR
4067                     && PL_expect != XTERMORDORDOR)
4068             {
4069                 /* any sub overrides the "err" keyword, except when really an
4070                  * operator is expected */
4071                 tmp = 0;
4072             }
4073             else {                      /* no override */
4074                 tmp = -tmp;
4075                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4076                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4077                             "dump() better written as CORE::dump()");
4078                 }
4079                 gv = Nullgv;
4080                 gvp = 0;
4081                 if (ckWARN(WARN_AMBIGUOUS) && hgv
4082                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4083                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4084                         "Ambiguous call resolved as CORE::%s(), %s",
4085                          GvENAME(hgv), "qualify as such or use &");
4086             }
4087         }
4088
4089       reserved_word:
4090         switch (tmp) {
4091
4092         default:                        /* not a keyword */
4093           just_a_word: {
4094                 SV *sv;
4095                 int pkgname = 0;
4096                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4097
4098                 /* Get the rest if it looks like a package qualifier */
4099
4100                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4101                     STRLEN morelen;
4102                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4103                                   TRUE, &morelen);
4104                     if (!morelen)
4105                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4106                                 *s == '\'' ? "'" : "::");
4107                     len += morelen;
4108                     pkgname = 1;
4109                 }
4110
4111                 if (PL_expect == XOPERATOR) {
4112                     if (PL_bufptr == PL_linestart) {
4113                         CopLINE_dec(PL_curcop);
4114                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4115                         CopLINE_inc(PL_curcop);
4116                     }
4117                     else
4118                         no_op("Bareword",s);
4119                 }
4120
4121                 /* Look for a subroutine with this name in current package,
4122                    unless name is "Foo::", in which case Foo is a bearword
4123                    (and a package name). */
4124
4125                 if (len > 2 &&
4126                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4127                 {
4128                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4129                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4130                             "Bareword \"%s\" refers to nonexistent package",
4131                              PL_tokenbuf);
4132                     len -= 2;
4133                     PL_tokenbuf[len] = '\0';
4134                     gv = Nullgv;
4135                     gvp = 0;
4136                 }
4137                 else {
4138                     len = 0;
4139                     if (!gv)
4140                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4141                 }
4142
4143                 /* if we saw a global override before, get the right name */
4144
4145                 if (gvp) {
4146                     sv = newSVpvn("CORE::GLOBAL::",14);
4147                     sv_catpv(sv,PL_tokenbuf);
4148                 }
4149                 else {
4150                     /* If len is 0, newSVpv does strlen(), which is correct.
4151                        If len is non-zero, then it will be the true length,
4152                        and so the scalar will be created correctly.  */
4153                     sv = newSVpv(PL_tokenbuf,len);
4154                 }
4155
4156                 /* Presume this is going to be a bareword of some sort. */
4157
4158                 CLINE;
4159                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4160                 yylval.opval->op_private = OPpCONST_BARE;
4161                 /* UTF-8 package name? */
4162                 if (UTF && !IN_BYTES &&
4163                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4164                     SvUTF8_on(sv);
4165
4166                 /* And if "Foo::", then that's what it certainly is. */
4167
4168                 if (len)
4169                     goto safe_bareword;
4170
4171                 /* See if it's the indirect object for a list operator. */
4172
4173                 if (PL_oldoldbufptr &&
4174                     PL_oldoldbufptr < PL_bufptr &&
4175                     (PL_oldoldbufptr == PL_last_lop
4176                      || PL_oldoldbufptr == PL_last_uni) &&
4177                     /* NO SKIPSPACE BEFORE HERE! */
4178                     (PL_expect == XREF ||
4179                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4180                 {
4181                     bool immediate_paren = *s == '(';
4182
4183                     /* (Now we can afford to cross potential line boundary.) */
4184                     s = skipspace(s);
4185
4186                     /* Two barewords in a row may indicate method call. */
4187
4188                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4189                         return REPORT(tmp);
4190
4191                     /* If not a declared subroutine, it's an indirect object. */
4192                     /* (But it's an indir obj regardless for sort.) */
4193
4194                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4195                          ((!gv || !GvCVu(gv)) &&
4196                         (PL_last_lop_op != OP_MAPSTART &&
4197                          PL_last_lop_op != OP_GREPSTART))))
4198                     {
4199                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4200                         goto bareword;
4201                     }
4202                 }
4203
4204                 PL_expect = XOPERATOR;
4205                 s = skipspace(s);
4206
4207                 /* Is this a word before a => operator? */
4208                 if (*s == '=' && s[1] == '>' && !pkgname) {
4209                     CLINE;
4210                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4211                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4212                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4213                     TERM(WORD);
4214                 }
4215
4216                 /* If followed by a paren, it's certainly a subroutine. */
4217                 if (*s == '(') {
4218                     CLINE;
4219                     if (gv && GvCVu(gv)) {
4220                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4221                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4222                             s = d + 1;
4223                             goto its_constant;
4224                         }
4225                     }
4226                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4227                     PL_expect = XOPERATOR;
4228                     force_next(WORD);
4229                     yylval.ival = 0;
4230                     TOKEN('&');
4231                 }
4232
4233                 /* If followed by var or block, call it a method (unless sub) */
4234
4235                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4236                     PL_last_lop = PL_oldbufptr;
4237                     PL_last_lop_op = OP_METHOD;
4238                     PREBLOCK(METHOD);
4239                 }
4240
4241                 /* If followed by a bareword, see if it looks like indir obj. */
4242
4243                 if (!orig_keyword
4244                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4245                         && (tmp = intuit_method(s,gv)))
4246                     return REPORT(tmp);
4247
4248                 /* Not a method, so call it a subroutine (if defined) */
4249
4250                 if (gv && GvCVu(gv)) {
4251                     CV* cv;
4252                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4253                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4254                                 "Ambiguous use of -%s resolved as -&%s()",
4255                                 PL_tokenbuf, PL_tokenbuf);
4256                     /* Check for a constant sub */
4257                     cv = GvCV(gv);
4258                     if ((sv = cv_const_sv(cv))) {
4259                   its_constant:
4260                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4261             &n