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