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