toke.c

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