toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  *   "It all comes from here, the stench and the peril."  --Frodo
  12  */
  13
  14 /*
  15  * This file is the lexer for Perl.  It's closely linked to the
  16  * parser, perly.y.
  17  *
  18  * The main routine is yylex(), which returns the next token.
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_TOKE_C
  23 #include "perl.h"
  24
  25 #define yychar  PL_yychar
  26 #define yylval  PL_yylval
  27
  28 static char ident_too_long[] = "Identifier too long";
  29
  30 static void restore_rsfp(pTHX_ void *f);
  31 #ifndef PERL_NO_UTF16_FILTER
  32 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  33 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  34 #endif
  35
  36 #define XFAKEBRACK 128
  37 #define XENUMMASK 127
  38
  39 #ifdef USE_UTF8_SCRIPTS
  40 #   define UTF (!IN_BYTES)
  41 #else
  42 #   ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
  43 #       define UTF (PL_linestr && DO_UTF8(PL_linestr))
  44 #   else
  45 #       define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  46 #   endif
  47 #endif
  48
  49 /* In variables named $^X, these are the legal values for X.
  50  * 1999-02-27 mjd-perl-patch@plover.com */
  51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  52
  53 /* On MacOS, respect nonbreaking spaces */
  54 #ifdef MACOS_TRADITIONAL
  55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  56 #else
  57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  58 #endif
  59
  60 /* LEX_* are values for PL_lex_state, the state of the lexer.
  61  * They are arranged oddly so that the guard on the switch statement
  62  * can get by with a single comparison (if the compiler is smart enough).
  63  */
  64
  65 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  66
  67 #define LEX_NORMAL              10
  68 #define LEX_INTERPNORMAL         9
  69 #define LEX_INTERPCASEMOD        8
  70 #define LEX_INTERPPUSH           7
  71 #define LEX_INTERPSTART          6
  72 #define LEX_INTERPEND            5
  73 #define LEX_INTERPENDMAYBE       4
  74 #define LEX_INTERPCONCAT         3
  75 #define LEX_INTERPCONST          2
  76 #define LEX_FORMLINE             1
  77 #define LEX_KNOWNEXT             0
  78
  79 #ifdef ff_next
  80 #undef ff_next
  81 #endif
  82
  83 #ifdef USE_PURE_BISON
  84 #  ifndef YYMAXLEVEL
  85 #    define YYMAXLEVEL 100
  86 #  endif
  87 YYSTYPE* yylval_pointer[YYMAXLEVEL];
  88 int* yychar_pointer[YYMAXLEVEL];
  89 int yyactlevel = -1;
  90 #  undef yylval
  91 #  undef yychar
  92 #  define yylval (*yylval_pointer[yyactlevel])
  93 #  define yychar (*yychar_pointer[yyactlevel])
  94 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
  95 #  undef yylex
  96 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
  97 #endif
  98
  99 #include "keywords.h"
 100
 101 /* CLINE is a macro that ensures PL_copline has a sane value */
 102
 103 #ifdef CLINE
 104 #undef CLINE
 105 #endif
 106 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 107
 108 /*
 109  * Convenience functions to return different tokens and prime the
 110  * lexer for the next token.  They all take an argument.
 111  *
 112  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 113  * OPERATOR     : generic operator
 114  * AOPERATOR    : assignment operator
 115  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 116  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 117  * PREREF       : *EXPR where EXPR is not a simple identifier
 118  * TERM         : expression term
 119  * LOOPX        : loop exiting command (goto, last, dump, etc)
 120  * FTST         : file test operator
 121  * FUN0         : zero-argument function
 122  * FUN1         : not used, except for not, which isn't a UNIOP
 123  * BOop         : bitwise or or xor
 124  * BAop         : bitwise and
 125  * SHop         : shift operator
 126  * PWop         : power operator
 127  * PMop         : pattern-matching operator
 128  * Aop          : addition-level operator
 129  * Mop          : multiplication-level operator
 130  * Eop          : equality-testing operator
 131  * Rop          : relational operator <= != gt
 132  *
 133  * Also see LOP and lop() below.
 134  */
 135
 136 /* Note that REPORT() and REPORT2() will be expressions that supply
 137  * their own trailing comma, not suitable for statements as such. */
 138 #ifdef DEBUGGING /* Serve -DT. */
 139 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
 140 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
 141 #else
 142 #   define REPORT(x,retval)
 143 #   define REPORT2(x,retval)
 144 #endif
 145
 146 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
 147 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
 148 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
 149 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 150 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 151 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
 152 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
 153 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 154 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 155 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 156 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 157 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 158 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 159 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 160 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 161 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 162 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 163 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 164 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 165 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 166
 167 /* This bit of chicanery makes a unary function followed by
 168  * a parenthesis into a function with one argument, highest precedence.
 169  */
 170 #define UNI(f) return(yylval.ival = f, \
 171         REPORT("uni",f) \
 172         PL_expect = XTERM, \
 173         PL_bufptr = s, \
 174         PL_last_uni = PL_oldbufptr, \
 175         PL_last_lop_op = f, \
 176         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 177
 178 #define UNIBRACK(f) return(yylval.ival = f, \
 179         REPORT("uni",f) \
 180         PL_bufptr = s, \
 181         PL_last_uni = PL_oldbufptr, \
 182         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 183
 184 /* grandfather return to old style */
 185 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 186
 187 #ifdef DEBUGGING
 188
 189 STATIC void
 190 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 191 {
 192     DEBUG_T({
 193         SV* report = newSVpv(thing, 0);
 194         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
 195                 (IV)rv);
 196
 197         if (s - PL_bufptr > 0)
 198             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
 199         else {
 200             if (PL_oldbufptr && *PL_oldbufptr)
 201                 sv_catpv(report, PL_tokenbuf);
 202         }
 203         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
 204     });
 205 }
 206
 207 #endif
 208
 209 /*
 210  * S_ao
 211  *
 212  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
 213  * into an OP_ANDASSIGN or OP_ORASSIGN
 214  */
 215
 216 STATIC int
 217 S_ao(pTHX_ int toketype)
 218 {
 219     if (*PL_bufptr == '=') {
 220         PL_bufptr++;
 221         if (toketype == ANDAND)
 222             yylval.ival = OP_ANDASSIGN;
 223         else if (toketype == OROR)
 224             yylval.ival = OP_ORASSIGN;
 225         toketype = ASSIGNOP;
 226     }
 227     return toketype;
 228 }
 229
 230 /*
 231  * S_no_op
 232  * When Perl expects an operator and finds something else, no_op
 233  * prints the warning.  It always prints "<something> found where
 234  * operator expected.  It prints "Missing semicolon on previous line?"
 235  * if the surprise occurs at the start of the line.  "do you need to
 236  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 237  * where the compiler doesn't know if foo is a method call or a function.
 238  * It prints "Missing operator before end of line" if there's nothing
 239  * after the missing operator, or "... before <...>" if there is something
 240  * after the missing operator.
 241  */
 242
 243 STATIC void
 244 S_no_op(pTHX_ char *what, char *s)
 245 {
 246     char *oldbp = PL_bufptr;
 247     bool is_first = (PL_oldbufptr == PL_linestart);
 248
 249     if (!s)
 250         s = oldbp;
 251     else
 252         PL_bufptr = s;
 253     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 254     if (is_first)
 255         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 256     else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 257         char *t;
 258         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 259         if (t < PL_bufptr && isSPACE(*t))
 260             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 261                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 262     }
 263     else {
 264         assert(s >= oldbp);
 265         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 266     }
 267     PL_bufptr = oldbp;
 268 }
 269
 270 /*
 271  * S_missingterm
 272  * Complain about missing quote/regexp/heredoc terminator.
 273  * If it's called with (char *)NULL then it cauterizes the line buffer.
 274  * If we're in a delimited string and the delimiter is a control
 275  * character, it's reformatted into a two-char sequence like ^C.
 276  * This is fatal.
 277  */
 278
 279 STATIC void
 280 S_missingterm(pTHX_ char *s)
 281 {
 282     char tmpbuf[3];
 283     char q;
 284     if (s) {
 285         char *nl = strrchr(s,'\n');
 286         if (nl)
 287             *nl = '\0';
 288     }
 289     else if (
 290 #ifdef EBCDIC
 291         iscntrl(PL_multi_close)
 292 #else
 293         PL_multi_close < 32 || PL_multi_close == 127
 294 #endif
 295         ) {
 296         *tmpbuf = '^';
 297         tmpbuf[1] = toCTRL(PL_multi_close);
 298         s = "\\n";
 299         tmpbuf[2] = '\0';
 300         s = tmpbuf;
 301     }
 302     else {
 303         *tmpbuf = PL_multi_close;
 304         tmpbuf[1] = '\0';
 305         s = tmpbuf;
 306     }
 307     q = strchr(s,'"') ? '\'' : '"';
 308     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 309 }
 310
 311 /*
 312  * Perl_deprecate
 313  */
 314
 315 void
 316 Perl_deprecate(pTHX_ char *s)
 317 {
 318     if (ckWARN(WARN_DEPRECATED))
 319         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 320 }
 321
 322 /*
 323  * depcom
 324  * Deprecate a comma-less variable list.
 325  */
 326
 327 STATIC void
 328 S_depcom(pTHX)
 329 {
 330     deprecate("comma-less variable list");
 331 }
 332
 333 /*
 334  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 335  * utf16-to-utf8-reversed.
 336  */
 337
 338 #ifdef PERL_CR_FILTER
 339 static void
 340 strip_return(SV *sv)
 341 {
 342     register char *s = SvPVX(sv);
 343     register char *e = s + SvCUR(sv);
 344     /* outer loop optimized to do nothing if there are no CR-LFs */
 345     while (s < e) {
 346         if (*s++ == '\r' && *s == '\n') {
 347             /* hit a CR-LF, need to copy the rest */
 348             register char *d = s - 1;
 349             *d++ = *s++;
 350             while (s < e) {
 351                 if (*s == '\r' && s[1] == '\n')
 352                     s++;
 353                 *d++ = *s++;
 354             }
 355             SvCUR(sv) -= s - d;
 356             return;
 357         }
 358     }
 359 }
 360
 361 STATIC I32
 362 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 363 {
 364     I32 count = FILTER_READ(idx+1, sv, maxlen);
 365     if (count > 0 && !maxlen)
 366         strip_return(sv);
 367     return count;
 368 }
 369 #endif
 370
 371 /*
 372  * Perl_lex_start
 373  * Initialize variables.  Uses the Perl save_stack to save its state (for
 374  * recursive calls to the parser).
 375  */
 376
 377 void
 378 Perl_lex_start(pTHX_ SV *line)
 379 {
 380     char *s;
 381     STRLEN len;
 382
 383     SAVEI32(PL_lex_dojoin);
 384     SAVEI32(PL_lex_brackets);
 385     SAVEI32(PL_lex_casemods);
 386     SAVEI32(PL_lex_starts);
 387     SAVEI32(PL_lex_state);
 388     SAVEVPTR(PL_lex_inpat);
 389     SAVEI32(PL_lex_inwhat);
 390     if (PL_lex_state == LEX_KNOWNEXT) {
 391         I32 toke = PL_nexttoke;
 392         while (--toke >= 0) {
 393             SAVEI32(PL_nexttype[toke]);
 394             SAVEVPTR(PL_nextval[toke]);
 395         }
 396         SAVEI32(PL_nexttoke);
 397     }
 398     SAVECOPLINE(PL_curcop);
 399     SAVEPPTR(PL_bufptr);
 400     SAVEPPTR(PL_bufend);
 401     SAVEPPTR(PL_oldbufptr);
 402     SAVEPPTR(PL_oldoldbufptr);
 403     SAVEPPTR(PL_last_lop);
 404     SAVEPPTR(PL_last_uni);
 405     SAVEPPTR(PL_linestart);
 406     SAVESPTR(PL_linestr);
 407     SAVEPPTR(PL_lex_brackstack);
 408     SAVEPPTR(PL_lex_casestack);
 409     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 410     SAVESPTR(PL_lex_stuff);
 411     SAVEI32(PL_lex_defer);
 412     SAVEI32(PL_sublex_info.sub_inwhat);
 413     SAVESPTR(PL_lex_repl);
 414     SAVEINT(PL_expect);
 415     SAVEINT(PL_lex_expect);
 416
 417     PL_lex_state = LEX_NORMAL;
 418     PL_lex_defer = 0;
 419     PL_expect = XSTATE;
 420     PL_lex_brackets = 0;
 421     New(899, PL_lex_brackstack, 120, char);
 422     New(899, PL_lex_casestack, 12, char);
 423     SAVEFREEPV(PL_lex_brackstack);
 424     SAVEFREEPV(PL_lex_casestack);
 425     PL_lex_casemods = 0;
 426     *PL_lex_casestack = '\0';
 427     PL_lex_dojoin = 0;
 428     PL_lex_starts = 0;
 429     PL_lex_stuff = Nullsv;
 430     PL_lex_repl = Nullsv;
 431     PL_lex_inpat = 0;
 432     PL_nexttoke = 0;
 433     PL_lex_inwhat = 0;
 434     PL_sublex_info.sub_inwhat = 0;
 435     PL_linestr = line;
 436     if (SvREADONLY(PL_linestr))
 437         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 438     s = SvPV(PL_linestr, len);
 439     if (len && s[len-1] != ';') {
 440         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 441             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 442         sv_catpvn(PL_linestr, "\n;", 2);
 443     }
 444     SvTEMP_off(PL_linestr);
 445     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 446     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 447     PL_last_lop = PL_last_uni = Nullch;
 448     PL_rsfp = 0;
 449 }
 450
 451 /*
 452  * Perl_lex_end
 453  * Finalizer for lexing operations.  Must be called when the parser is
 454  * done with the lexer.
 455  */
 456
 457 void
 458 Perl_lex_end(pTHX)
 459 {
 460     PL_doextract = FALSE;
 461 }
 462
 463 /*
 464  * S_incline
 465  * This subroutine has nothing to do with tilting, whether at windmills
 466  * or pinball tables.  Its name is short for "increment line".  It
 467  * increments the current line number in CopLINE(PL_curcop) and checks
 468  * to see whether the line starts with a comment of the form
 469  *    # line 500 "foo.pm"
 470  * If so, it sets the current line number and file to the values in the comment.
 471  */
 472
 473 STATIC void
 474 S_incline(pTHX_ char *s)
 475 {
 476     char *t;
 477     char *n;
 478     char *e;
 479     char ch;
 480
 481     CopLINE_inc(PL_curcop);
 482     if (*s++ != '#')
 483         return;
 484     while (SPACE_OR_TAB(*s)) s++;
 485     if (strnEQ(s, "line", 4))
 486         s += 4;
 487     else
 488         return;
 489     if (SPACE_OR_TAB(*s))
 490         s++;
 491     else
 492         return;
 493     while (SPACE_OR_TAB(*s)) s++;
 494     if (!isDIGIT(*s))
 495         return;
 496     n = s;
 497     while (isDIGIT(*s))
 498         s++;
 499     while (SPACE_OR_TAB(*s))
 500         s++;
 501     if (*s == '"' && (t = strchr(s+1, '"'))) {
 502         s++;
 503         e = t + 1;
 504     }
 505     else {
 506         for (t = s; !isSPACE(*t); t++) ;
 507         e = t;
 508     }
 509     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 510         e++;
 511     if (*e != '\n' && *e != '\0')
 512         return;         /* false alarm */
 513
 514     ch = *t;
 515     *t = '\0';
 516     if (t - s > 0) {
 517 #ifdef USE_ITHREADS
 518         Safefree(CopFILE(PL_curcop));
 519 #else
 520         SvREFCNT_dec(CopFILEGV(PL_curcop));
 521 #endif
 522         CopFILE_set(PL_curcop, s);
 523     }
 524     *t = ch;
 525     CopLINE_set(PL_curcop, atoi(n)-1);
 526 }
 527
 528 /*
 529  * S_skipspace
 530  * Called to gobble the appropriate amount and type of whitespace.
 531  * Skips comments as well.
 532  */
 533
 534 STATIC char *
 535 S_skipspace(pTHX_ register char *s)
 536 {
 537     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 538         while (s < PL_bufend && SPACE_OR_TAB(*s))
 539             s++;
 540         return s;
 541     }
 542     for (;;) {
 543         STRLEN prevlen;
 544         SSize_t oldprevlen, oldoldprevlen;
 545         SSize_t oldloplen = 0, oldunilen = 0;
 546         while (s < PL_bufend && isSPACE(*s)) {
 547             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 548                 incline(s);
 549         }
 550
 551         /* comment */
 552         if (s < PL_bufend && *s == '#') {
 553             while (s < PL_bufend && *s != '\n')
 554                 s++;
 555             if (s < PL_bufend) {
 556                 s++;
 557                 if (PL_in_eval && !PL_rsfp) {
 558                     incline(s);
 559                     continue;
 560                 }
 561             }
 562         }
 563
 564         /* only continue to recharge the buffer if we're at the end
 565          * of the buffer, we're not reading from a source filter, and
 566          * we're in normal lexing mode
 567          */
 568         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 569                 PL_lex_state == LEX_FORMLINE)
 570             return s;
 571
 572         /* try to recharge the buffer */
 573         if ((s = filter_gets(PL_linestr, PL_rsfp,
 574                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 575         {
 576             /* end of file.  Add on the -p or -n magic */
 577             if (PL_minus_n || PL_minus_p) {
 578                 sv_setpv(PL_linestr,PL_minus_p ?
 579                          ";}continue{print or die qq(-p destination: $!\\n)" :
 580                          "");
 581                 sv_catpv(PL_linestr,";}");
 582                 PL_minus_n = PL_minus_p = 0;
 583             }
 584             else
 585                 sv_setpv(PL_linestr,";");
 586
 587             /* reset variables for next time we lex */
 588             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 589                 = SvPVX(PL_linestr);
 590             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 591             PL_last_lop = PL_last_uni = Nullch;
 592
 593             /* Close the filehandle.  Could be from -P preprocessor,
 594              * STDIN, or a regular file.  If we were reading code from
 595              * STDIN (because the commandline held no -e or filename)
 596              * then we don't close it, we reset it so the code can
 597              * read from STDIN too.
 598              */
 599
 600             if (PL_preprocess && !PL_in_eval)
 601                 (void)PerlProc_pclose(PL_rsfp);
 602             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 603                 PerlIO_clearerr(PL_rsfp);
 604             else
 605                 (void)PerlIO_close(PL_rsfp);
 606             PL_rsfp = Nullfp;
 607             return s;
 608         }
 609
 610         /* not at end of file, so we only read another line */
 611         /* make corresponding updates to old pointers, for yyerror() */
 612         oldprevlen = PL_oldbufptr - PL_bufend;
 613         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 614         if (PL_last_uni)
 615             oldunilen = PL_last_uni - PL_bufend;
 616         if (PL_last_lop)
 617             oldloplen = PL_last_lop - PL_bufend;
 618         PL_linestart = PL_bufptr = s + prevlen;
 619         PL_bufend = s + SvCUR(PL_linestr);
 620         s = PL_bufptr;
 621         PL_oldbufptr = s + oldprevlen;
 622         PL_oldoldbufptr = s + oldoldprevlen;
 623         if (PL_last_uni)
 624             PL_last_uni = s + oldunilen;
 625         if (PL_last_lop)
 626             PL_last_lop = s + oldloplen;
 627         incline(s);
 628
 629         /* debugger active and we're not compiling the debugger code,
 630          * so store the line into the debugger's array of lines
 631          */
 632         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 633             SV *sv = NEWSV(85,0);
 634
 635             sv_upgrade(sv, SVt_PVMG);
 636             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 637             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 638         }
 639     }
 640 }
 641
 642 /*
 643  * S_check_uni
 644  * Check the unary operators to ensure there's no ambiguity in how they're
 645  * used.  An ambiguous piece of code would be:
 646  *     rand + 5
 647  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 648  * the +5 is its argument.
 649  */
 650
 651 STATIC void
 652 S_check_uni(pTHX)
 653 {
 654     char *s;
 655     char *t;
 656
 657     if (PL_oldoldbufptr != PL_last_uni)
 658         return;
 659     while (isSPACE(*PL_last_uni))
 660         PL_last_uni++;
 661     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 662     if ((t = strchr(s, '(')) && t < PL_bufptr)
 663         return;
 664     if (ckWARN_d(WARN_AMBIGUOUS)){
 665         char ch = *s;
 666         *s = '\0';
 667         Perl_warner(aTHX_ WARN_AMBIGUOUS,
 668                    "Warning: Use of \"%s\" without parens is ambiguous",
 669                    PL_last_uni);
 670         *s = ch;
 671     }
 672 }
 673
 674 /* workaround to replace the UNI() macro with a function.  Only the
 675  * hints/uts.sh file mentions this.  Other comments elsewhere in the
 676  * source indicate Microport Unix might need it too.
 677  */
 678
 679 #ifdef CRIPPLED_CC
 680
 681 #undef UNI
 682 #define UNI(f) return uni(f,s)
 683
 684 STATIC int
 685 S_uni(pTHX_ I32 f, char *s)
 686 {
 687     yylval.ival = f;
 688     PL_expect = XTERM;
 689     PL_bufptr = s;
 690     PL_last_uni = PL_oldbufptr;
 691     PL_last_lop_op = f;
 692     if (*s == '(')
 693         return FUNC1;
 694     s = skipspace(s);
 695     if (*s == '(')
 696         return FUNC1;
 697     else
 698         return UNIOP;
 699 }
 700
 701 #endif /* CRIPPLED_CC */
 702
 703 /*
 704  * LOP : macro to build a list operator.  Its behaviour has been replaced
 705  * with a subroutine, S_lop() for which LOP is just another name.
 706  */
 707
 708 #define LOP(f,x) return lop(f,x,s)
 709
 710 /*
 711  * S_lop
 712  * Build a list operator (or something that might be one).  The rules:
 713  *  - if we have a next token, then it's a list operator [why?]
 714  *  - if the next thing is an opening paren, then it's a function
 715  *  - else it's a list operator
 716  */
 717
 718 STATIC I32
 719 S_lop(pTHX_ I32 f, int x, char *s)
 720 {
 721     yylval.ival = f;
 722     CLINE;
 723     REPORT("lop", f)
 724     PL_expect = x;
 725     PL_bufptr = s;
 726     PL_last_lop = PL_oldbufptr;
 727     PL_last_lop_op = f;
 728     if (PL_nexttoke)
 729         return LSTOP;
 730     if (*s == '(')
 731         return FUNC;
 732     s = skipspace(s);
 733     if (*s == '(')
 734         return FUNC;
 735     else
 736         return LSTOP;
 737 }
 738
 739 /*
 740  * S_force_next
 741  * When the lexer realizes it knows the next token (for instance,
 742  * it is reordering tokens for the parser) then it can call S_force_next
 743  * to know what token to return the next time the lexer is called.  Caller
 744  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 745  * handles the token correctly.
 746  */
 747
 748 STATIC void
 749 S_force_next(pTHX_ I32 type)
 750 {
 751     PL_nexttype[PL_nexttoke] = type;
 752     PL_nexttoke++;
 753     if (PL_lex_state != LEX_KNOWNEXT) {
 754         PL_lex_defer = PL_lex_state;
 755         PL_lex_expect = PL_expect;
 756         PL_lex_state = LEX_KNOWNEXT;
 757     }
 758 }
 759
 760 /*
 761  * S_force_word
 762  * When the lexer knows the next thing is a word (for instance, it has
 763  * just seen -> and it knows that the next char is a word char, then
 764  * it calls S_force_word to stick the next word into the PL_next lookahead.
 765  *
 766  * Arguments:
 767  *   char *start : buffer position (must be within PL_linestr)
 768  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 769  *   int check_keyword : if true, Perl checks to make sure the word isn't
 770  *       a keyword (do this if the word is a label, e.g. goto FOO)
 771  *   int allow_pack : if true, : characters will also be allowed (require,
 772  *       use, etc. do this)
 773  *   int allow_initial_tick : used by the "sub" lexer only.
 774  */
 775
 776 STATIC char *
 777 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 778 {
 779     register char *s;
 780     STRLEN len;
 781
 782     start = skipspace(start);
 783     s = start;
 784     if (isIDFIRST_lazy_if(s,UTF) ||
 785         (allow_pack && *s == ':') ||
 786         (allow_initial_tick && *s == '\'') )
 787     {
 788         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 789         if (check_keyword && keyword(PL_tokenbuf, len))
 790             return start;
 791         if (token == METHOD) {
 792             s = skipspace(s);
 793             if (*s == '(')
 794                 PL_expect = XTERM;
 795             else {
 796                 PL_expect = XOPERATOR;
 797             }
 798         }
 799         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 800         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 801         force_next(token);
 802     }
 803     return s;
 804 }
 805
 806 /*
 807  * S_force_ident
 808  * Called when the lexer wants $foo *foo &foo etc, but the program
 809  * text only contains the "foo" portion.  The first argument is a pointer
 810  * to the "foo", and the second argument is the type symbol to prefix.
 811  * Forces the next token to be a "WORD".
 812  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 813  */
 814
 815 STATIC void
 816 S_force_ident(pTHX_ register char *s, int kind)
 817 {
 818     if (s && *s) {
 819         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 820         PL_nextval[PL_nexttoke].opval = o;
 821         force_next(WORD);
 822         if (kind) {
 823             o->op_private = OPpCONST_ENTERED;
 824             /* XXX see note in pp_entereval() for why we forgo typo
 825                warnings if the symbol must be introduced in an eval.
 826                GSAR 96-10-12 */
 827             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 828                 kind == '$' ? SVt_PV :
 829                 kind == '@' ? SVt_PVAV :
 830                 kind == '%' ? SVt_PVHV :
 831                               SVt_PVGV
 832                 );
 833         }
 834     }
 835 }
 836
 837 NV
 838 Perl_str_to_version(pTHX_ SV *sv)
 839 {
 840     NV retval = 0.0;
 841     NV nshift = 1.0;
 842     STRLEN len;
 843     char *start = SvPVx(sv,len);
 844     bool utf = SvUTF8(sv) ? TRUE : FALSE;
 845     char *end = start + len;
 846     while (start < end) {
 847         STRLEN skip;
 848         UV n;
 849         if (utf)
 850             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
 851         else {
 852             n = *(U8*)start;
 853             skip = 1;
 854         }
 855         retval += ((NV)n)/nshift;
 856         start += skip;
 857         nshift *= 1000;
 858     }
 859     return retval;
 860 }
 861
 862 /*
 863  * S_force_version
 864  * Forces the next token to be a version number.
 865  * If the next token appears to be an invalid version number, (e.g. "v2b"),
 866  * and if "guessing" is TRUE, then no new token is created (and the caller
 867  * must use an alternative parsing method).
 868  */
 869
 870 STATIC char *
 871 S_force_version(pTHX_ char *s, int guessing)
 872 {
 873     OP *version = Nullop;
 874     char *d;
 875
 876     s = skipspace(s);
 877
 878     d = s;
 879     if (*d == 'v')
 880         d++;
 881     if (isDIGIT(*d)) {
 882         while (isDIGIT(*d) || *d == '_' || *d == '.')
 883             d++;
 884         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
 885             SV *ver;
 886             s = scan_num(s, &yylval);
 887             version = yylval.opval;
 888             ver = cSVOPx(version)->op_sv;
 889             if (SvPOK(ver) && !SvNIOK(ver)) {
 890                 (void)SvUPGRADE(ver, SVt_PVNV);
 891                 SvNVX(ver) = str_to_version(ver);
 892                 SvNOK_on(ver);          /* hint that it is a version */
 893             }
 894         }
 895         else if (guessing)
 896             return s;
 897     }
 898
 899     /* NOTE: The parser sees the package name and the VERSION swapped */
 900     PL_nextval[PL_nexttoke].opval = version;
 901     force_next(WORD);
 902
 903     return s;
 904 }
 905
 906 /*
 907  * S_tokeq
 908  * Tokenize a quoted string passed in as an SV.  It finds the next
 909  * chunk, up to end of string or a backslash.  It may make a new
 910  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 911  * turns \\ into \.
 912  */
 913
 914 STATIC SV *
 915 S_tokeq(pTHX_ SV *sv)
 916 {
 917     register char *s;
 918     register char *send;
 919     register char *d;
 920     STRLEN len = 0;
 921     SV *pv = sv;
 922
 923     if (!SvLEN(sv))
 924         goto finish;
 925
 926     s = SvPV_force(sv, len);
 927     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
 928         goto finish;
 929     send = s + len;
 930     while (s < send && *s != '\\')
 931         s++;
 932     if (s == send)
 933         goto finish;
 934     d = s;
 935     if ( PL_hints & HINT_NEW_STRING ) {
 936         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 937         if (SvUTF8(sv))
 938             SvUTF8_on(pv);
 939     }
 940     while (s < send) {
 941         if (*s == '\\') {
 942             if (s + 1 < send && (s[1] == '\\'))
 943                 s++;            /* all that, just for this */
 944         }
 945         *d++ = *s++;
 946     }
 947     *d = '\0';
 948     SvCUR_set(sv, d - SvPVX(sv));
 949   finish:
 950     if ( PL_hints & HINT_NEW_STRING )
 951        return new_constant(NULL, 0, "q", sv, pv, "q");
 952     return sv;
 953 }
 954
 955 /*
 956  * Now come three functions related to double-quote context,
 957  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 958  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 959  * interact with PL_lex_state, and create fake ( ... ) argument lists
 960  * to handle functions and concatenation.
 961  * They assume that whoever calls them will be setting up a fake
 962  * join call, because each subthing puts a ',' after it.  This lets
 963  *   "lower \luPpEr"
 964  * become
 965  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 966  *
 967  * (I'm not sure whether the spurious commas at the end of lcfirst's
 968  * arguments and join's arguments are created or not).
 969  */
 970
 971 /*
 972  * S_sublex_start
 973  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 974  *
 975  * Pattern matching will set PL_lex_op to the pattern-matching op to
 976  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 977  *
 978  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 979  *
 980  * Everything else becomes a FUNC.
 981  *
 982  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 983  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 984  * call to S_sublex_push().
 985  */
 986
 987 STATIC I32
 988 S_sublex_start(pTHX)
 989 {
 990     register I32 op_type = yylval.ival;
 991
 992     if (op_type == OP_NULL) {
 993         yylval.opval = PL_lex_op;
 994         PL_lex_op = Nullop;
 995         return THING;
 996     }
 997     if (op_type == OP_CONST || op_type == OP_READLINE) {
 998         SV *sv = tokeq(PL_lex_stuff);
 999
1000         if (SvTYPE(sv) == SVt_PVIV) {
1001             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1002             STRLEN len;
1003             char *p;
1004             SV *nsv;
1005
1006             p = SvPV(sv, len);
1007             nsv = newSVpvn(p, len);
1008             if (SvUTF8(sv))
1009                 SvUTF8_on(nsv);
1010             SvREFCNT_dec(sv);
1011             sv = nsv;
1012         }
1013         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1014         PL_lex_stuff = Nullsv;
1015         return THING;
1016     }
1017
1018     PL_sublex_info.super_state = PL_lex_state;
1019     PL_sublex_info.sub_inwhat = op_type;
1020     PL_sublex_info.sub_op = PL_lex_op;
1021     PL_lex_state = LEX_INTERPPUSH;
1022
1023     PL_expect = XTERM;
1024     if (PL_lex_op) {
1025         yylval.opval = PL_lex_op;
1026         PL_lex_op = Nullop;
1027         return PMFUNC;
1028     }
1029     else
1030         return FUNC;
1031 }
1032
1033 /*
1034  * S_sublex_push
1035  * Create a new scope to save the lexing state.  The scope will be
1036  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1037  * to the uc, lc, etc. found before.
1038  * Sets PL_lex_state to LEX_INTERPCONCAT.
1039  */
1040
1041 STATIC I32
1042 S_sublex_push(pTHX)
1043 {
1044     ENTER;
1045
1046     PL_lex_state = PL_sublex_info.super_state;
1047     SAVEI32(PL_lex_dojoin);
1048     SAVEI32(PL_lex_brackets);
1049     SAVEI32(PL_lex_casemods);
1050     SAVEI32(PL_lex_starts);
1051     SAVEI32(PL_lex_state);
1052     SAVEVPTR(PL_lex_inpat);
1053     SAVEI32(PL_lex_inwhat);
1054     SAVECOPLINE(PL_curcop);
1055     SAVEPPTR(PL_bufptr);
1056     SAVEPPTR(PL_bufend);
1057     SAVEPPTR(PL_oldbufptr);
1058     SAVEPPTR(PL_oldoldbufptr);
1059     SAVEPPTR(PL_last_lop);
1060     SAVEPPTR(PL_last_uni);
1061     SAVEPPTR(PL_linestart);
1062     SAVESPTR(PL_linestr);
1063     SAVEPPTR(PL_lex_brackstack);
1064     SAVEPPTR(PL_lex_casestack);
1065
1066     PL_linestr = PL_lex_stuff;
1067     PL_lex_stuff = Nullsv;
1068
1069     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1070         = SvPVX(PL_linestr);
1071     PL_bufend += SvCUR(PL_linestr);
1072     PL_last_lop = PL_last_uni = Nullch;
1073     SAVEFREESV(PL_linestr);
1074
1075     PL_lex_dojoin = FALSE;
1076     PL_lex_brackets = 0;
1077     New(899, PL_lex_brackstack, 120, char);
1078     New(899, PL_lex_casestack, 12, char);
1079     SAVEFREEPV(PL_lex_brackstack);
1080     SAVEFREEPV(PL_lex_casestack);
1081     PL_lex_casemods = 0;
1082     *PL_lex_casestack = '\0';
1083     PL_lex_starts = 0;
1084     PL_lex_state = LEX_INTERPCONCAT;
1085     CopLINE_set(PL_curcop, PL_multi_start);
1086
1087     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1088     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1089         PL_lex_inpat = PL_sublex_info.sub_op;
1090     else
1091         PL_lex_inpat = Nullop;
1092
1093     return '(';
1094 }
1095
1096 /*
1097  * S_sublex_done
1098  * Restores lexer state after a S_sublex_push.
1099  */
1100
1101 STATIC I32
1102 S_sublex_done(pTHX)
1103 {
1104     if (!PL_lex_starts++) {
1105         SV *sv = newSVpvn("",0);
1106         if (SvUTF8(PL_linestr))
1107             SvUTF8_on(sv);
1108         PL_expect = XOPERATOR;
1109         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1110         return THING;
1111     }
1112
1113     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1114         PL_lex_state = LEX_INTERPCASEMOD;
1115         return yylex();
1116     }
1117
1118     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1119     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1120         PL_linestr = PL_lex_repl;
1121         PL_lex_inpat = 0;
1122         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1123         PL_bufend += SvCUR(PL_linestr);
1124         PL_last_lop = PL_last_uni = Nullch;
1125         SAVEFREESV(PL_linestr);
1126         PL_lex_dojoin = FALSE;
1127         PL_lex_brackets = 0;
1128         PL_lex_casemods = 0;
1129         *PL_lex_casestack = '\0';
1130         PL_lex_starts = 0;
1131         if (SvEVALED(PL_lex_repl)) {
1132             PL_lex_state = LEX_INTERPNORMAL;
1133             PL_lex_starts++;
1134             /*  we don't clear PL_lex_repl here, so that we can check later
1135                 whether this is an evalled subst; that means we rely on the
1136                 logic to ensure sublex_done() is called again only via the
1137                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1138         }
1139         else {
1140             PL_lex_state = LEX_INTERPCONCAT;
1141             PL_lex_repl = Nullsv;
1142         }
1143         return ',';
1144     }
1145     else {
1146         LEAVE;
1147         PL_bufend = SvPVX(PL_linestr);
1148         PL_bufend += SvCUR(PL_linestr);
1149         PL_expect = XOPERATOR;
1150         PL_sublex_info.sub_inwhat = 0;
1151         return ')';
1152     }
1153 }
1154
1155 /*
1156   scan_const
1157
1158   Extracts a pattern, double-quoted string, or transliteration.  This
1159   is terrifying code.
1160
1161   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1162   processing a pattern (PL_lex_inpat is true), a transliteration
1163   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1164
1165   Returns a pointer to the character scanned up to. Iff this is
1166   advanced from the start pointer supplied (ie if anything was
1167   successfully parsed), will leave an OP for the substring scanned
1168   in yylval. Caller must intuit reason for not parsing further
1169   by looking at the next characters herself.
1170
1171   In patterns:
1172     backslashes:
1173       double-quoted style: \r and \n
1174       regexp special ones: \D \s
1175       constants: \x3
1176       backrefs: \1 (deprecated in substitution replacements)
1177       case and quoting: \U \Q \E
1178     stops on @ and $, but not for $ as tail anchor
1179
1180   In transliterations:
1181     characters are VERY literal, except for - not at the start or end
1182     of the string, which indicates a range.  scan_const expands the
1183     range to the full set of intermediate characters.
1184
1185   In double-quoted strings:
1186     backslashes:
1187       double-quoted style: \r and \n
1188       constants: \x3
1189       backrefs: \1 (deprecated)
1190       case and quoting: \U \Q \E
1191     stops on @ and $
1192
1193   scan_const does *not* construct ops to handle interpolated strings.
1194   It stops processing as soon as it finds an embedded $ or @ variable
1195   and leaves it to the caller to work out what's going on.
1196
1197   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1198
1199   $ in pattern could be $foo or could be tail anchor.  Assumption:
1200   it's a tail anchor if $ is the last thing in the string, or if it's
1201   followed by one of ")| \n\t"
1202
1203   \1 (backreferences) are turned into $1
1204
1205   The structure of the code is
1206       while (there's a character to process) {
1207           handle transliteration ranges
1208           skip regexp comments
1209           skip # initiated comments in //x patterns
1210           check for embedded @foo
1211           check for embedded scalars
1212           if (backslash) {
1213               leave intact backslashes from leave (below)
1214               deprecate \1 in strings and sub replacements
1215               handle string-changing backslashes \l \U \Q \E, etc.
1216               switch (what was escaped) {
1217                   handle - in a transliteration (becomes a literal -)
1218                   handle \132 octal characters
1219                   handle 0x15 hex characters
1220                   handle \cV (control V)
1221                   handle printf backslashes (\f, \r, \n, etc)
1222               } (end switch)
1223           } (end if backslash)
1224     } (end while character to read)
1225
1226 */
1227
1228 STATIC char *
1229 S_scan_const(pTHX_ char *start)
1230 {
1231     register char *send = PL_bufend;            /* end of the constant */
1232     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1233     register char *s = start;                   /* start of the constant */
1234     register char *d = SvPVX(sv);               /* destination for copies */
1235     bool dorange = FALSE;                       /* are we in a translit range? */
1236     bool didrange = FALSE;                      /* did we just finish a range? */
1237     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1238     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1239     UV uv;
1240
1241     const char *leaveit =       /* set of acceptably-backslashed characters */
1242         PL_lex_inpat
1243             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1244             : "";
1245
1246     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1247         /* If we are doing a trans and we know we want UTF8 set expectation */
1248         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1249         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1250     }
1251
1252
1253     while (s < send || dorange) {
1254         /* get transliterations out of the way (they're most literal) */
1255         if (PL_lex_inwhat == OP_TRANS) {
1256             /* expand a range A-Z to the full set of characters.  AIE! */
1257             if (dorange) {
1258                 I32 i;                          /* current expanded character */
1259                 I32 min;                        /* first character in range */
1260                 I32 max;                        /* last character in range */
1261
1262                 if (has_utf8) {
1263                     char *c = (char*)utf8_hop((U8*)d, -1);
1264                     char *e = d++;
1265                     while (e-- > c)
1266                         *(e + 1) = *e;
1267                     *c = (char)UTF_TO_NATIVE(0xff);
1268                     /* mark the range as done, and continue */
1269                     dorange = FALSE;
1270                     didrange = TRUE;
1271                     continue;
1272                 }
1273
1274                 i = d - SvPVX(sv);              /* remember current offset */
1275                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1276                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1277                 d -= 2;                         /* eat the first char and the - */
1278
1279                 min = (U8)*d;                   /* first char in range */
1280                 max = (U8)d[1];                 /* last char in range  */
1281
1282                 if (min > max) {
1283                     Perl_croak(aTHX_
1284                                "Invalid [] range \"%c-%c\" in transliteration operator",
1285                                (char)min, (char)max);
1286                 }
1287
1288 #ifdef EBCDIC
1289                 if ((isLOWER(min) && isLOWER(max)) ||
1290                     (isUPPER(min) && isUPPER(max))) {
1291                     if (isLOWER(min)) {
1292                         for (i = min; i <= max; i++)
1293                             if (isLOWER(i))
1294                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1295                     } else {
1296                         for (i = min; i <= max; i++)
1297                             if (isUPPER(i))
1298                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1299                     }
1300                 }
1301                 else
1302 #endif
1303                     for (i = min; i <= max; i++)
1304                         *d++ = i;
1305
1306                 /* mark the range as done, and continue */
1307                 dorange = FALSE;
1308                 didrange = TRUE;
1309                 continue;
1310             }
1311
1312             /* range begins (ignore - as first or last char) */
1313             else if (*s == '-' && s+1 < send  && s != start) {
1314                 if (didrange) {
1315                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1316                 }
1317                 if (has_utf8) {
1318                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1319                     s++;
1320                     continue;
1321                 }
1322                 dorange = TRUE;
1323                 s++;
1324             }
1325             else {
1326                 didrange = FALSE;
1327             }
1328         }
1329
1330         /* if we get here, we're not doing a transliteration */
1331
1332         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1333            except for the last char, which will be done separately. */
1334         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1335             if (s[2] == '#') {
1336                 while (s < send && *s != ')')
1337                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1338             }
1339             else if (s[2] == '{' /* This should match regcomp.c */
1340                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1341             {
1342                 I32 count = 1;
1343                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1344                 char c;
1345
1346                 while (count && (c = *regparse)) {
1347                     if (c == '\\' && regparse[1])
1348                         regparse++;
1349                     else if (c == '{')
1350                         count++;
1351                     else if (c == '}')
1352                         count--;
1353                     regparse++;
1354                 }
1355                 if (*regparse != ')') {
1356                     regparse--;         /* Leave one char for continuation. */
1357                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1358                 }
1359                 while (s < regparse)
1360                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1361             }
1362         }
1363
1364         /* likewise skip #-initiated comments in //x patterns */
1365         else if (*s == '#' && PL_lex_inpat &&
1366           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1367             while (s+1 < send && *s != '\n')
1368                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1369         }
1370
1371         /* check for embedded arrays
1372            (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1373            */
1374         else if (*s == '@' && s[1]
1375                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1376             break;
1377
1378         /* check for embedded scalars.  only stop if we're sure it's a
1379            variable.
1380         */
1381         else if (*s == '$') {
1382             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1383                 break;
1384             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1385                 break;          /* in regexp, $ might be tail anchor */
1386         }
1387
1388         /* End of else if chain - OP_TRANS rejoin rest */
1389
1390         /* backslashes */
1391         if (*s == '\\' && s+1 < send) {
1392             s++;
1393
1394             /* some backslashes we leave behind */
1395             if (*leaveit && *s && strchr(leaveit, *s)) {
1396                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1397                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1398                 continue;
1399             }
1400
1401             /* deprecate \1 in strings and substitution replacements */
1402             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1403                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1404             {
1405                 if (ckWARN(WARN_SYNTAX))
1406                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1407                 *--s = '$';
1408                 break;
1409             }
1410
1411             /* string-change backslash escapes */
1412             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1413                 --s;
1414                 break;
1415             }
1416
1417             /* if we get here, it's either a quoted -, or a digit */
1418             switch (*s) {
1419
1420             /* quoted - in transliterations */
1421             case '-':
1422                 if (PL_lex_inwhat == OP_TRANS) {
1423                     *d++ = *s++;
1424                     continue;
1425                 }
1426                 /* FALL THROUGH */
1427             default:
1428                 {
1429                     if (ckWARN(WARN_MISC) && isALNUM(*s))
1430                         Perl_warner(aTHX_ WARN_MISC,
1431                                "Unrecognized escape \\%c passed through",
1432                                *s);
1433                     /* default action is to copy the quoted character */
1434                     goto default_action;
1435                 }
1436
1437             /* \132 indicates an octal constant */
1438             case '0': case '1': case '2': case '3':
1439             case '4': case '5': case '6': case '7':
1440                 {
1441                     I32 flags = 0;
1442                     STRLEN len = 3;
1443                     uv = grok_oct(s, &len, &flags, NULL);
1444                     s += len;
1445                 }
1446                 goto NUM_ESCAPE_INSERT;
1447
1448             /* \x24 indicates a hex constant */
1449             case 'x':
1450                 ++s;
1451                 if (*s == '{') {
1452                     char* e = strchr(s, '}');
1453                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1454                       PERL_SCAN_DISALLOW_PREFIX;
1455                     STRLEN len;
1456
1457                     ++s;
1458                     if (!e) {
1459                         yyerror("Missing right brace on \\x{}");
1460                         continue;
1461                     }
1462                     len = e - s;
1463                     uv = grok_hex(s, &len, &flags, NULL);
1464                     s = e + 1;
1465                 }
1466                 else {
1467                     {
1468                         STRLEN len = 2;
1469                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1470                         uv = grok_hex(s, &len, &flags, NULL);
1471                         s += len;
1472                     }
1473                 }
1474
1475               NUM_ESCAPE_INSERT:
1476                 /* Insert oct or hex escaped character.
1477                  * There will always enough room in sv since such
1478                  * escapes will be longer than any UTF-8 sequence
1479                  * they can end up as. */
1480
1481                 /* We need to map to chars to ASCII before doing the tests
1482                    to cover EBCDIC
1483                 */
1484                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1485                     if (!has_utf8 && uv > 255) {
1486                         /* Might need to recode whatever we have
1487                          * accumulated so far if it contains any
1488                          * hibit chars.
1489                          *
1490                          * (Can't we keep track of that and avoid
1491                          *  this rescan? --jhi)
1492                          */
1493                         int hicount = 0;
1494                         U8 *c;
1495                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1496                             if (!NATIVE_IS_INVARIANT(*c)) {
1497                                 hicount++;
1498                             }
1499                         }
1500                         if (hicount) {
1501                             STRLEN offset = d - SvPVX(sv);
1502                             U8 *src, *dst;
1503                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1504                             src = (U8 *)d - 1;
1505                             dst = src+hicount;
1506                             d  += hicount;
1507                             while (src >= (U8 *)SvPVX(sv)) {
1508                                 if (!NATIVE_IS_INVARIANT(*src)) {
1509                                     U8 ch = NATIVE_TO_ASCII(*src);
1510                                     *dst-- = UTF8_EIGHT_BIT_LO(ch);
1511                                     *dst-- = UTF8_EIGHT_BIT_HI(ch);
1512                                 }
1513                                 else {
1514                                     *dst-- = *src;
1515                                 }
1516                                 src--;
1517                             }
1518                         }
1519                     }
1520
1521                     if (has_utf8 || uv > 255) {
1522                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1523                         has_utf8 = TRUE;
1524                         if (PL_lex_inwhat == OP_TRANS &&
1525                             PL_sublex_info.sub_op) {
1526                             PL_sublex_info.sub_op->op_private |=
1527                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1528                                              : OPpTRANS_TO_UTF);
1529                         }
1530                     }
1531                     else {
1532                         *d++ = (char)uv;
1533                     }
1534                 }
1535                 else {
1536                     *d++ = (char) uv;
1537                 }
1538                 continue;
1539
1540             /* \N{LATIN SMALL LETTER A} is a named character */
1541             case 'N':
1542                 ++s;
1543                 if (*s == '{') {
1544                     char* e = strchr(s, '}');
1545                     SV *res;
1546                     STRLEN len;
1547                     char *str;
1548
1549                     if (!e) {
1550                         yyerror("Missing right brace on \\N{}");
1551                         e = s - 1;
1552                         goto cont_scan;
1553                     }
1554                     res = newSVpvn(s + 1, e - s - 1);
1555                     res = new_constant( Nullch, 0, "charnames",
1556                                         res, Nullsv, "\\N{...}" );
1557                     if (has_utf8)
1558                         sv_utf8_upgrade(res);
1559                     str = SvPV(res,len);
1560                     if (!has_utf8 && SvUTF8(res)) {
1561                         char *ostart = SvPVX(sv);
1562                         SvCUR_set(sv, d - ostart);
1563                         SvPOK_on(sv);
1564                         *d = '\0';
1565                         sv_utf8_upgrade(sv);
1566                         /* this just broke our allocation above... */
1567                         SvGROW(sv, send - start);
1568                         d = SvPVX(sv) + SvCUR(sv);
1569                         has_utf8 = TRUE;
1570                     }
1571                     if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
1572                         char *odest = SvPVX(sv);
1573
1574                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1575                         d = SvPVX(sv) + (d - odest);
1576                     }
1577                     Copy(str, d, len, char);
1578                     d += len;
1579                     SvREFCNT_dec(res);
1580                   cont_scan:
1581                     s = e + 1;
1582                 }
1583                 else
1584                     yyerror("Missing braces on \\N{}");
1585                 continue;
1586
1587             /* \c is a control character */
1588             case 'c':
1589                 s++;
1590                 {
1591                     U8 c = *s++;
1592 #ifdef EBCDIC
1593                     if (isLOWER(c))
1594                         c = toUPPER(c);
1595 #endif
1596                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1597                 }
1598                 continue;
1599
1600             /* printf-style backslashes, formfeeds, newlines, etc */
1601             case 'b':
1602                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1603                 break;
1604             case 'n':
1605                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1606                 break;
1607             case 'r':
1608                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1609                 break;
1610             case 'f':
1611                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1612                 break;
1613             case 't':
1614                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1615                 break;
1616             case 'e':
1617                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1618                 break;
1619             case 'a':
1620                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1621                 break;
1622             } /* end switch */
1623
1624             s++;
1625             continue;
1626         } /* end if (backslash) */
1627
1628     default_action:
1629         /* If we started with encoded form, or already know we want it
1630            and then encode the next character */
1631         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1632             STRLEN len  = 1;
1633             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1634             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1635             s += len;
1636             if (need > len) {
1637                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1638                 STRLEN off = d - SvPVX(sv);
1639                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1640             }
1641             d = (char*)uvchr_to_utf8((U8*)d, uv);
1642             has_utf8 = TRUE;
1643         }
1644         else {
1645             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1646         }
1647     } /* while loop to process each character */
1648
1649     /* terminate the string and set up the sv */
1650     *d = '\0';
1651     SvCUR_set(sv, d - SvPVX(sv));
1652     if (SvCUR(sv) >= SvLEN(sv))
1653       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1654
1655     SvPOK_on(sv);
1656     if (PL_encoding && !has_utf8) {
1657         Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
1658         has_utf8 = TRUE;
1659     }
1660     if (has_utf8) {
1661         SvUTF8_on(sv);
1662         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1663                 PL_sublex_info.sub_op->op_private |=
1664                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1665         }
1666     }
1667
1668     /* shrink the sv if we allocated more than we used */
1669     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1670         SvLEN_set(sv, SvCUR(sv) + 1);
1671         Renew(SvPVX(sv), SvLEN(sv), char);
1672     }
1673
1674     /* return the substring (via yylval) only if we parsed anything */
1675     if (s > PL_bufptr) {
1676         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1677             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1678                               sv, Nullsv,
1679                               ( PL_lex_inwhat == OP_TRANS
1680                                 ? "tr"
1681                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1682                                     ? "s"
1683                                     : "qq")));
1684         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1685     } else
1686         SvREFCNT_dec(sv);
1687     return s;
1688 }
1689
1690 /* S_intuit_more
1691  * Returns TRUE if there's more to the expression (e.g., a subscript),
1692  * FALSE otherwise.
1693  *
1694  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1695  *
1696  * ->[ and ->{ return TRUE
1697  * { and [ outside a pattern are always subscripts, so return TRUE
1698  * if we're outside a pattern and it's not { or [, then return FALSE
1699  * if we're in a pattern and the first char is a {
1700  *   {4,5} (any digits around the comma) returns FALSE
1701  * if we're in a pattern and the first char is a [
1702  *   [] returns FALSE
1703  *   [SOMETHING] has a funky algorithm to decide whether it's a
1704  *      character class or not.  It has to deal with things like
1705  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1706  * anything else returns TRUE
1707  */
1708
1709 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1710
1711 STATIC int
1712 S_intuit_more(pTHX_ register char *s)
1713 {
1714     if (PL_lex_brackets)
1715         return TRUE;
1716     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1717         return TRUE;
1718     if (*s != '{' && *s != '[')
1719         return FALSE;
1720     if (!PL_lex_inpat)
1721         return TRUE;
1722
1723     /* In a pattern, so maybe we have {n,m}. */
1724     if (*s == '{') {
1725         s++;
1726         if (!isDIGIT(*s))
1727             return TRUE;
1728         while (isDIGIT(*s))
1729             s++;
1730         if (*s == ',')
1731             s++;
1732         while (isDIGIT(*s))
1733             s++;
1734         if (*s == '}')
1735             return FALSE;
1736         return TRUE;
1737
1738     }
1739
1740     /* On the other hand, maybe we have a character class */
1741
1742     s++;
1743     if (*s == ']' || *s == '^')
1744         return FALSE;
1745     else {
1746         /* this is terrifying, and it works */
1747         int weight = 2;         /* let's weigh the evidence */
1748         char seen[256];
1749         unsigned char un_char = 255, last_un_char;
1750         char *send = strchr(s,']');
1751         char tmpbuf[sizeof PL_tokenbuf * 4];
1752
1753         if (!send)              /* has to be an expression */
1754             return TRUE;
1755
1756         Zero(seen,256,char);
1757         if (*s == '$')
1758             weight -= 3;
1759         else if (isDIGIT(*s)) {
1760             if (s[1] != ']') {
1761                 if (isDIGIT(s[1]) && s[2] == ']')
1762                     weight -= 10;
1763             }
1764             else
1765                 weight -= 100;
1766         }
1767         for (; s < send; s++) {
1768             last_un_char = un_char;
1769             un_char = (unsigned char)*s;
1770             switch (*s) {
1771             case '@':
1772             case '&':
1773             case '$':
1774                 weight -= seen[un_char] * 10;
1775                 if (isALNUM_lazy_if(s+1,UTF)) {
1776                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1777                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1778                         weight -= 100;
1779                     else
1780                         weight -= 10;
1781                 }
1782                 else if (*s == '$' && s[1] &&
1783                   strchr("[#!%*<>()-=",s[1])) {
1784                     if (/*{*/ strchr("])} =",s[2]))
1785                         weight -= 10;
1786                     else
1787                         weight -= 1;
1788                 }
1789                 break;
1790             case '\\':
1791                 un_char = 254;
1792                 if (s[1]) {
1793                     if (strchr("wds]",s[1]))
1794                         weight += 100;
1795                     else if (seen['\''] || seen['"'])
1796                         weight += 1;
1797                     else if (strchr("rnftbxcav",s[1]))
1798                         weight += 40;
1799                     else if (isDIGIT(s[1])) {
1800                         weight += 40;
1801                         while (s[1] && isDIGIT(s[1]))
1802                             s++;
1803                     }
1804                 }
1805                 else
1806                     weight += 100;
1807                 break;
1808             case '-':
1809                 if (s[1] == '\\')
1810                     weight += 50;
1811                 if (strchr("aA01! ",last_un_char))
1812                     weight += 30;
1813                 if (strchr("zZ79~",s[1]))
1814                     weight += 30;
1815                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1816                     weight -= 5;        /* cope with negative subscript */
1817                 break;
1818             default:
1819                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1820                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1821                     char *d = tmpbuf;
1822                     while (isALPHA(*s))
1823                         *d++ = *s++;
1824                     *d = '\0';
1825                     if (keyword(tmpbuf, d - tmpbuf))
1826                         weight -= 150;
1827                 }
1828                 if (un_char == last_un_char + 1)
1829                     weight += 5;
1830                 weight -= seen[un_char];
1831                 break;
1832             }
1833             seen[un_char]++;
1834         }
1835         if (weight >= 0)        /* probably a character class */
1836             return FALSE;
1837     }
1838
1839     return TRUE;
1840 }
1841
1842 /*
1843  * S_intuit_method
1844  *
1845  * Does all the checking to disambiguate
1846  *   foo bar
1847  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1848  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1849  *
1850  * First argument is the stuff after the first token, e.g. "bar".
1851  *
1852  * Not a method if bar is a filehandle.
1853  * Not a method if foo is a subroutine prototyped to take a filehandle.
1854  * Not a method if it's really "Foo $bar"
1855  * Method if it's "foo $bar"
1856  * Not a method if it's really "print foo $bar"
1857  * Method if it's really "foo package::" (interpreted as package->foo)
1858  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1859  * Not a method if bar is a filehandle or package, but is quoted with
1860  *   =>
1861  */
1862
1863 STATIC int
1864 S_intuit_method(pTHX_ char *start, GV *gv)
1865 {
1866     char *s = start + (*start == '$');
1867     char tmpbuf[sizeof PL_tokenbuf];
1868     STRLEN len;
1869     GV* indirgv;
1870
1871     if (gv) {
1872         CV *cv;
1873         if (GvIO(gv))
1874             return 0;
1875         if ((cv = GvCVu(gv))) {
1876             char *proto = SvPVX(cv);
1877             if (proto) {
1878                 if (*proto == ';')
1879                     proto++;
1880                 if (*proto == '*')
1881                     return 0;
1882             }
1883         } else
1884             gv = 0;
1885     }
1886     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1887     /* start is the beginning of the possible filehandle/object,
1888      * and s is the end of it
1889      * tmpbuf is a copy of it
1890      */
1891
1892     if (*start == '$') {
1893         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1894             return 0;
1895         s = skipspace(s);
1896         PL_bufptr = start;
1897         PL_expect = XREF;
1898         return *s == '(' ? FUNCMETH : METHOD;
1899     }
1900     if (!keyword(tmpbuf, len)) {
1901         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1902             len -= 2;
1903             tmpbuf[len] = '\0';
1904             goto bare_package;
1905         }
1906         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1907         if (indirgv && GvCVu(indirgv))
1908             return 0;
1909         /* filehandle or package name makes it a method */
1910         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1911             s = skipspace(s);
1912             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1913                 return 0;       /* no assumptions -- "=>" quotes bearword */
1914       bare_package:
1915             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1916                                                    newSVpvn(tmpbuf,len));
1917             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1918             PL_expect = XTERM;
1919             force_next(WORD);
1920             PL_bufptr = s;
1921             return *s == '(' ? FUNCMETH : METHOD;
1922         }
1923     }
1924     return 0;
1925 }
1926
1927 /*
1928  * S_incl_perldb
1929  * Return a string of Perl code to load the debugger.  If PERL5DB
1930  * is set, it will return the contents of that, otherwise a
1931  * compile-time require of perl5db.pl.
1932  */
1933
1934 STATIC char*
1935 S_incl_perldb(pTHX)
1936 {
1937     if (PL_perldb) {
1938         char *pdb = PerlEnv_getenv("PERL5DB");
1939
1940         if (pdb)
1941             return pdb;
1942         SETERRNO(0,SS$_NORMAL);
1943         return "BEGIN { require 'perl5db.pl' }";
1944     }
1945     return "";
1946 }
1947
1948
1949 /* Encoded script support. filter_add() effectively inserts a
1950  * 'pre-processing' function into the current source input stream.
1951  * Note that the filter function only applies to the current source file
1952  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1953  *
1954  * The datasv parameter (which may be NULL) can be used to pass
1955  * private data to this instance of the filter. The filter function
1956  * can recover the SV using the FILTER_DATA macro and use it to
1957  * store private buffers and state information.
1958  *
1959  * The supplied datasv parameter is upgraded to a PVIO type
1960  * and the IoDIRP/IoANY field is used to store the function pointer,
1961  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1962  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1963  * private use must be set using malloc'd pointers.
1964  */
1965
1966 SV *
1967 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1968 {
1969     if (!funcp)
1970         return Nullsv;
1971
1972     if (!PL_rsfp_filters)
1973         PL_rsfp_filters = newAV();
1974     if (!datasv)
1975         datasv = NEWSV(255,0);
1976     if (!SvUPGRADE(datasv, SVt_PVIO))
1977         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1978     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1979     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1980     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1981                           funcp, SvPV_nolen(datasv)));
1982     av_unshift(PL_rsfp_filters, 1);
1983     av_store(PL_rsfp_filters, 0, datasv) ;
1984     return(datasv);
1985 }
1986
1987
1988 /* Delete most recently added instance of this filter function. */
1989 void
1990 Perl_filter_del(pTHX_ filter_t funcp)
1991 {
1992     SV *datasv;
1993     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1994     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1995         return;
1996     /* if filter is on top of stack (usual case) just pop it off */
1997     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1998     if (IoANY(datasv) == (void *)funcp) {
1999         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2000         IoANY(datasv) = (void *)NULL;
2001         sv_free(av_pop(PL_rsfp_filters));
2002
2003         return;
2004     }
2005     /* we need to search for the correct entry and clear it     */
2006     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2007 }
2008
2009
2010 /* Invoke the n'th filter function for the current rsfp.         */
2011 I32
2012 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2013
2014
2015                         /* 0 = read one text line */
2016 {
2017     filter_t funcp;
2018     SV *datasv = NULL;
2019
2020     if (!PL_rsfp_filters)
2021         return -1;
2022     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2023         /* Provide a default input filter to make life easy.    */
2024         /* Note that we append to the line. This is handy.      */
2025         DEBUG_P(PerlIO_printf(Perl_debug_log,
2026                               "filter_read %d: from rsfp\n", idx));
2027         if (maxlen) {
2028             /* Want a block */
2029             int len ;
2030             int old_len = SvCUR(buf_sv) ;
2031
2032             /* ensure buf_sv is large enough */
2033             SvGROW(buf_sv, old_len + maxlen) ;
2034             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2035                 if (PerlIO_error(PL_rsfp))
2036                     return -1;          /* error */
2037                 else
2038                     return 0 ;          /* end of file */
2039             }
2040             SvCUR_set(buf_sv, old_len + len) ;
2041         } else {
2042             /* Want a line */
2043             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2044                 if (PerlIO_error(PL_rsfp))
2045                     return -1;          /* error */
2046                 else
2047                     return 0 ;          /* end of file */
2048             }
2049         }
2050         return SvCUR(buf_sv);
2051     }
2052     /* Skip this filter slot if filter has been deleted */
2053     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2054         DEBUG_P(PerlIO_printf(Perl_debug_log,
2055                               "filter_read %d: skipped (filter deleted)\n",
2056                               idx));
2057         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2058     }
2059     /* Get function pointer hidden within datasv        */
2060     funcp = (filter_t)IoANY(datasv);
2061     DEBUG_P(PerlIO_printf(Perl_debug_log,
2062                           "filter_read %d: via function %p (%s)\n",
2063                           idx, funcp, SvPV_nolen(datasv)));
2064     /* Call function. The function is expected to       */
2065     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2066     /* Return: <0:error, =0:eof, >0:not eof             */
2067     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2068 }
2069
2070 STATIC char *
2071 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2072 {
2073 #ifdef PERL_CR_FILTER
2074     if (!PL_rsfp_filters) {
2075         filter_add(S_cr_textfilter,NULL);
2076     }
2077 #endif
2078     if (PL_rsfp_filters) {
2079
2080         if (!append)
2081             SvCUR_set(sv, 0);   /* start with empty line        */
2082         if (FILTER_READ(0, sv, 0) > 0)
2083             return ( SvPVX(sv) ) ;
2084         else
2085             return Nullch ;
2086     }
2087     else
2088         return (sv_gets(sv, fp, append));
2089 }
2090
2091 STATIC HV *
2092 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2093 {
2094     GV *gv;
2095
2096     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2097         return PL_curstash;
2098
2099     if (len > 2 &&
2100         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2101         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2102     {
2103         return GvHV(gv);                        /* Foo:: */
2104     }
2105
2106     /* use constant CLASS => 'MyClass' */
2107     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2108         SV *sv;
2109         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2110             pkgname = SvPV_nolen(sv);
2111         }
2112     }
2113
2114     return gv_stashpv(pkgname, FALSE);
2115 }
2116
2117 #ifdef DEBUGGING
2118     static char* exp_name[] =
2119         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2120           "ATTRTERM", "TERMBLOCK"
2121         };
2122 #endif
2123
2124 /*
2125   yylex
2126
2127   Works out what to call the token just pulled out of the input
2128   stream.  The yacc parser takes care of taking the ops we return and
2129   stitching them into a tree.
2130
2131   Returns:
2132     PRIVATEREF
2133
2134   Structure:
2135       if read an identifier
2136           if we're in a my declaration
2137               croak if they tried to say my($foo::bar)
2138               build the ops for a my() declaration
2139           if it's an access to a my() variable
2140               are we in a sort block?
2141                   croak if my($a); $a <=> $b
2142               build ops for access to a my() variable
2143           if in a dq string, and they've said @foo and we can't find @foo
2144               croak
2145           build ops for a bareword
2146       if we already built the token before, use it.
2147 */
2148
2149 #ifdef USE_PURE_BISON
2150 int
2151 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2152 {
2153     int r;
2154
2155     yyactlevel++;
2156     yylval_pointer[yyactlevel] = lvalp;
2157     yychar_pointer[yyactlevel] = lcharp;
2158     if (yyactlevel >= YYMAXLEVEL)
2159         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2160
2161     r = Perl_yylex(aTHX);
2162
2163     if (yyactlevel > 0)
2164        yyactlevel--;
2165
2166     return r;
2167 }
2168 #endif
2169
2170 #ifdef __SC__
2171 #pragma segment Perl_yylex
2172 #endif
2173 int
2174 Perl_yylex(pTHX)
2175 {
2176     register char *s;
2177     register char *d;
2178     register I32 tmp;
2179     STRLEN len;
2180     GV *gv = Nullgv;
2181     GV **gvp = 0;
2182     bool bof = FALSE;
2183
2184     /* check if there's an identifier for us to look at */
2185     if (PL_pending_ident)
2186         return S_pending_ident(aTHX);
2187
2188     /* no identifier pending identification */
2189
2190     switch (PL_lex_state) {
2191 #ifdef COMMENTARY
2192     case LEX_NORMAL:            /* Some compilers will produce faster */
2193     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2194         break;
2195 #endif
2196
2197     /* when we've already built the next token, just pull it out of the queue */
2198     case LEX_KNOWNEXT:
2199         PL_nexttoke--;
2200         yylval = PL_nextval[PL_nexttoke];
2201         if (!PL_nexttoke) {
2202             PL_lex_state = PL_lex_defer;
2203             PL_expect = PL_lex_expect;
2204             PL_lex_defer = LEX_NORMAL;
2205         }
2206         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2207               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2208               (IV)PL_nexttype[PL_nexttoke]); });
2209
2210         return(PL_nexttype[PL_nexttoke]);
2211
2212     /* interpolated case modifiers like \L \U, including \Q and \E.
2213        when we get here, PL_bufptr is at the \
2214     */
2215     case LEX_INTERPCASEMOD:
2216 #ifdef DEBUGGING
2217         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2218             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2219 #endif
2220         /* handle \E or end of string */
2221         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2222             char oldmod;
2223
2224             /* if at a \E */
2225             if (PL_lex_casemods) {
2226                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2227                 PL_lex_casestack[PL_lex_casemods] = '\0';
2228
2229                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2230                     PL_bufptr += 2;
2231                     PL_lex_state = LEX_INTERPCONCAT;
2232                 }
2233                 return ')';
2234             }
2235             if (PL_bufptr != PL_bufend)
2236                 PL_bufptr += 2;
2237             PL_lex_state = LEX_INTERPCONCAT;
2238             return yylex();
2239         }
2240         else {
2241             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2242               "### Saw case modifier at '%s'\n", PL_bufptr); });
2243             s = PL_bufptr + 1;
2244             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2245                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2246             if (strchr("LU", *s) &&
2247                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2248             {
2249                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2250                 return ')';
2251             }
2252             if (PL_lex_casemods > 10) {
2253                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2254                 if (newlb != PL_lex_casestack) {
2255                     SAVEFREEPV(newlb);
2256                     PL_lex_casestack = newlb;
2257                 }
2258             }
2259             PL_lex_casestack[PL_lex_casemods++] = *s;
2260             PL_lex_casestack[PL_lex_casemods] = '\0';
2261             PL_lex_state = LEX_INTERPCONCAT;
2262             PL_nextval[PL_nexttoke].ival = 0;
2263             force_next('(');
2264             if (*s == 'l')
2265                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2266             else if (*s == 'u')
2267                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2268             else if (*s == 'L')
2269                 PL_nextval[PL_nexttoke].ival = OP_LC;
2270             else if (*s == 'U')
2271                 PL_nextval[PL_nexttoke].ival = OP_UC;
2272             else if (*s == 'Q')
2273                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2274             else
2275                 Perl_croak(aTHX_ "panic: yylex");
2276             PL_bufptr = s + 1;
2277             force_next(FUNC);
2278             if (PL_lex_starts) {
2279                 s = PL_bufptr;
2280                 PL_lex_starts = 0;
2281                 Aop(OP_CONCAT);
2282             }
2283             else
2284                 return yylex();
2285         }
2286
2287     case LEX_INTERPPUSH:
2288         return sublex_push();
2289
2290     case LEX_INTERPSTART:
2291         if (PL_bufptr == PL_bufend)
2292             return sublex_done();
2293         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2294               "### Interpolated variable at '%s'\n", PL_bufptr); });
2295         PL_expect = XTERM;
2296         PL_lex_dojoin = (*PL_bufptr == '@');
2297         PL_lex_state = LEX_INTERPNORMAL;
2298         if (PL_lex_dojoin) {
2299             PL_nextval[PL_nexttoke].ival = 0;
2300             force_next(',');
2301 #ifdef USE_5005THREADS
2302             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2303             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2304             force_next(PRIVATEREF);
2305 #else
2306             force_ident("\"", '$');
2307 #endif /* USE_5005THREADS */
2308             PL_nextval[PL_nexttoke].ival = 0;
2309             force_next('$');
2310             PL_nextval[PL_nexttoke].ival = 0;
2311             force_next('(');
2312             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2313             force_next(FUNC);
2314         }
2315         if (PL_lex_starts++) {
2316             s = PL_bufptr;
2317             Aop(OP_CONCAT);
2318         }
2319         return yylex();
2320
2321     case LEX_INTERPENDMAYBE:
2322         if (intuit_more(PL_bufptr)) {
2323             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2324             break;
2325         }
2326         /* FALL THROUGH */
2327
2328     case LEX_INTERPEND:
2329         if (PL_lex_dojoin) {
2330             PL_lex_dojoin = FALSE;
2331             PL_lex_state = LEX_INTERPCONCAT;
2332             return ')';
2333         }
2334         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2335             && SvEVALED(PL_lex_repl))
2336         {
2337             if (PL_bufptr != PL_bufend)
2338                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2339             PL_lex_repl = Nullsv;
2340         }
2341         /* FALLTHROUGH */
2342     case LEX_INTERPCONCAT:
2343 #ifdef DEBUGGING
2344         if (PL_lex_brackets)
2345             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2346 #endif
2347         if (PL_bufptr == PL_bufend)
2348             return sublex_done();
2349
2350         if (SvIVX(PL_linestr) == '\'') {
2351             SV *sv = newSVsv(PL_linestr);
2352             if (!PL_lex_inpat)
2353                 sv = tokeq(sv);
2354             else if ( PL_hints & HINT_NEW_RE )
2355                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2356             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2357             s = PL_bufend;
2358         }
2359         else {
2360             s = scan_const(PL_bufptr);
2361             if (*s == '\\')
2362                 PL_lex_state = LEX_INTERPCASEMOD;
2363             else
2364                 PL_lex_state = LEX_INTERPSTART;
2365         }
2366
2367         if (s != PL_bufptr) {
2368             PL_nextval[PL_nexttoke] = yylval;
2369             PL_expect = XTERM;
2370             force_next(THING);
2371             if (PL_lex_starts++)
2372                 Aop(OP_CONCAT);
2373             else {
2374                 PL_bufptr = s;
2375                 return yylex();
2376             }
2377         }
2378
2379         return yylex();
2380     case LEX_FORMLINE:
2381         PL_lex_state = LEX_NORMAL;
2382         s = scan_formline(PL_bufptr);
2383         if (!PL_lex_formbrack)
2384             goto rightbracket;
2385         OPERATOR(';');
2386     }
2387
2388     s = PL_bufptr;
2389     PL_oldoldbufptr = PL_oldbufptr;
2390     PL_oldbufptr = s;
2391     DEBUG_T( {
2392         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2393                       exp_name[PL_expect], s);
2394     } );
2395
2396   retry:
2397     switch (*s) {
2398     default:
2399         if (isIDFIRST_lazy_if(s,UTF))
2400             goto keylookup;
2401         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2402     case 4:
2403     case 26:
2404         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2405     case 0:
2406         if (!PL_rsfp) {
2407             PL_last_uni = 0;
2408             PL_last_lop = 0;
2409             if (PL_lex_brackets)
2410                 yyerror("Missing right curly or square bracket");
2411             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2412                         "### Tokener got EOF\n");
2413             } );
2414             TOKEN(0);
2415         }
2416         if (s++ < PL_bufend)
2417             goto retry;                 /* ignore stray nulls */
2418         PL_last_uni = 0;
2419         PL_last_lop = 0;
2420         if (!PL_in_eval && !PL_preambled) {
2421             PL_preambled = TRUE;
2422             sv_setpv(PL_linestr,incl_perldb());
2423             if (SvCUR(PL_linestr))
2424                 sv_catpv(PL_linestr,";");
2425             if (PL_preambleav){
2426                 while(AvFILLp(PL_preambleav) >= 0) {
2427                     SV *tmpsv = av_shift(PL_preambleav);
2428                     sv_catsv(PL_linestr, tmpsv);
2429                     sv_catpv(PL_linestr, ";");
2430                     sv_free(tmpsv);
2431                 }
2432                 sv_free((SV*)PL_preambleav);
2433                 PL_preambleav = NULL;
2434             }
2435             if (PL_minus_n || PL_minus_p) {
2436                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2437                 if (PL_minus_l)
2438                     sv_catpv(PL_linestr,"chomp;");
2439                 if (PL_minus_a) {
2440                     if (PL_minus_F) {
2441                         if (strchr("/'\"", *PL_splitstr)
2442                               && strchr(PL_splitstr + 1, *PL_splitstr))
2443                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2444                         else {
2445                             char delim;
2446                             s = "'~#\200\1'"; /* surely one char is unused...*/
2447                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2448                             delim = *s;
2449                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2450                                       "q" + (delim == '\''), delim);
2451                             for (s = PL_splitstr; *s; s++) {
2452                                 if (*s == '\\')
2453                                     sv_catpvn(PL_linestr, "\\", 1);
2454                                 sv_catpvn(PL_linestr, s, 1);
2455                             }
2456                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2457                         }
2458                     }
2459                     else
2460                         sv_catpv(PL_linestr,"our @F=split(' ');");
2461                 }
2462             }
2463             sv_catpv(PL_linestr, "\n");
2464             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2465             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2466             PL_last_lop = PL_last_uni = Nullch;
2467             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2468                 SV *sv = NEWSV(85,0);
2469
2470                 sv_upgrade(sv, SVt_PVMG);
2471                 sv_setsv(sv,PL_linestr);
2472                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2473             }
2474             goto retry;
2475         }
2476         do {
2477             bof = PL_rsfp ? TRUE : FALSE;
2478             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2479               fake_eof:
2480                 if (PL_rsfp) {
2481                     if (PL_preprocess && !PL_in_eval)
2482                         (void)PerlProc_pclose(PL_rsfp);
2483                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2484                         PerlIO_clearerr(PL_rsfp);
2485                     else
2486                         (void)PerlIO_close(PL_rsfp);
2487                     PL_rsfp = Nullfp;
2488                     PL_doextract = FALSE;
2489                 }
2490                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2491                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2492                     sv_catpv(PL_linestr,";}");
2493                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2494                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2495                     PL_last_lop = PL_last_uni = Nullch;
2496                     PL_minus_n = PL_minus_p = 0;
2497                     goto retry;
2498                 }
2499                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2500                 PL_last_lop = PL_last_uni = Nullch;
2501                 sv_setpv(PL_linestr,"");
2502                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2503             }
2504             /* if it looks like the start of a BOM, check if it in fact is */
2505             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2506 #ifdef PERLIO_IS_STDIO
2507 #  ifdef __GNU_LIBRARY__
2508 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2509 #      define FTELL_FOR_PIPE_IS_BROKEN
2510 #    endif
2511 #  else
2512 #    ifdef __GLIBC__
2513 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2514 #        define FTELL_FOR_PIPE_IS_BROKEN
2515 #      endif
2516 #    endif
2517 #  endif
2518 #endif
2519 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2520                 /* This loses the possibility to detect the bof
2521                  * situation on perl -P when the libc5 is being used.
2522                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2523                  */
2524                 if (!PL_preprocess)
2525                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2526 #else
2527                 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2528 #endif
2529                 if (bof) {
2530                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2531                     s = swallow_bom((U8*)s);
2532                 }
2533             }
2534             if (PL_doextract) {
2535                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2536                     PL_doextract = FALSE;
2537
2538                 /* Incest with pod. */
2539                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2540                     sv_setpv(PL_linestr, "");
2541                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2542                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2543                     PL_last_lop = PL_last_uni = Nullch;
2544                     PL_doextract = FALSE;
2545                 }
2546             }
2547             incline(s);
2548         } while (PL_doextract);
2549         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2550         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2551             SV *sv = NEWSV(85,0);
2552
2553             sv_upgrade(sv, SVt_PVMG);
2554             sv_setsv(sv,PL_linestr);
2555             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2556         }
2557         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2558         PL_last_lop = PL_last_uni = Nullch;
2559         if (CopLINE(PL_curcop) == 1) {
2560             while (s < PL_bufend && isSPACE(*s))
2561                 s++;
2562             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2563                 s++;
2564             d = Nullch;
2565             if (!PL_in_eval) {
2566                 if (*s == '#' && *(s+1) == '!')
2567                     d = s + 2;
2568 #ifdef ALTERNATE_SHEBANG
2569                 else {
2570                     static char as[] = ALTERNATE_SHEBANG;
2571                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2572                         d = s + (sizeof(as) - 1);
2573                 }
2574 #endif /* ALTERNATE_SHEBANG */
2575             }
2576             if (d) {
2577                 char *ipath;
2578                 char *ipathend;
2579
2580                 while (isSPACE(*d))
2581                     d++;
2582                 ipath = d;
2583                 while (*d && !isSPACE(*d))
2584                     d++;
2585                 ipathend = d;
2586
2587 #ifdef ARG_ZERO_IS_SCRIPT
2588                 if (ipathend > ipath) {
2589                     /*
2590                      * HP-UX (at least) sets argv[0] to the script name,
2591                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2592                      * at least, set argv[0] to the basename of the Perl
2593                      * interpreter. So, having found "#!", we'll set it right.
2594                      */
2595                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2596                     assert(SvPOK(x) || SvGMAGICAL(x));
2597                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2598                         sv_setpvn(x, ipath, ipathend - ipath);
2599                         SvSETMAGIC(x);
2600                     }
2601                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2602                 }
2603 #endif /* ARG_ZERO_IS_SCRIPT */
2604
2605                 /*
2606                  * Look for options.
2607                  */
2608                 d = instr(s,"perl -");
2609                 if (!d) {
2610                     d = instr(s,"perl");
2611 #if defined(DOSISH)
2612                     /* avoid getting into infinite loops when shebang
2613                      * line contains "Perl" rather than "perl" */
2614                     if (!d) {
2615                         for (d = ipathend-4; d >= ipath; --d) {
2616                             if ((*d == 'p' || *d == 'P')
2617                                 && !ibcmp(d, "perl", 4))
2618                             {
2619                                 break;
2620                             }
2621                         }
2622                         if (d < ipath)
2623                             d = Nullch;
2624                     }
2625 #endif
2626                 }
2627 #ifdef ALTERNATE_SHEBANG
2628                 /*
2629                  * If the ALTERNATE_SHEBANG on this system starts with a
2630                  * character that can be part of a Perl expression, then if
2631                  * we see it but not "perl", we're probably looking at the
2632                  * start of Perl code, not a request to hand off to some
2633                  * other interpreter.  Similarly, if "perl" is there, but
2634                  * not in the first 'word' of the line, we assume the line
2635                  * contains the start of the Perl program.
2636                  */
2637                 if (d && *s != '#') {
2638                     char *c = ipath;
2639                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2640                         c++;
2641                     if (c < d)
2642                         d = Nullch;     /* "perl" not in first word; ignore */
2643                     else
2644                         *s = '#';       /* Don't try to parse shebang line */
2645                 }
2646 #endif /* ALTERNATE_SHEBANG */
2647 #ifndef MACOS_TRADITIONAL
2648                 if (!d &&
2649                     *s == '#' &&
2650                     ipathend > ipath &&
2651                     !PL_minus_c &&
2652                     !instr(s,"indir") &&
2653                     instr(PL_origargv[0],"perl"))
2654                 {
2655                     char **newargv;
2656
2657                     *ipathend = '\0';
2658                     s = ipathend + 1;
2659                     while (s < PL_bufend && isSPACE(*s))
2660                         s++;
2661                     if (s < PL_bufend) {
2662                         Newz(899,newargv,PL_origargc+3,char*);
2663                         newargv[1] = s;
2664                         while (s < PL_bufend && !isSPACE(*s))
2665                             s++;
2666                         *s = '\0';
2667                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2668                     }
2669                     else
2670                         newargv = PL_origargv;
2671                     newargv[0] = ipath;
2672                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2673                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2674                 }
2675 #endif
2676                 if (d) {
2677                     U32 oldpdb = PL_perldb;
2678                     bool oldn = PL_minus_n;
2679                     bool oldp = PL_minus_p;
2680
2681                     while (*d && !isSPACE(*d)) d++;
2682                     while (SPACE_OR_TAB(*d)) d++;
2683
2684                     if (*d++ == '-') {
2685                         do {
2686                             if (*d == 'M' || *d == 'm') {
2687                                 char *m = d;
2688                                 while (*d && !isSPACE(*d)) d++;
2689                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2690                                       (int)(d - m), m);
2691                             }
2692                             d = moreswitches(d);
2693                         } while (d);
2694                         if ((PERLDB_LINE && !oldpdb) ||
2695                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2696                               /* if we have already added "LINE: while (<>) {",
2697                                  we must not do it again */
2698                         {
2699                             sv_setpv(PL_linestr, "");
2700                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2701                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2702                             PL_last_lop = PL_last_uni = Nullch;
2703                             PL_preambled = FALSE;
2704                             if (PERLDB_LINE)
2705                                 (void)gv_fetchfile(PL_origfilename);
2706                             goto retry;
2707                         }
2708                     }
2709                 }
2710             }
2711         }
2712         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2713             PL_bufptr = s;
2714             PL_lex_state = LEX_FORMLINE;
2715             return yylex();
2716         }
2717         goto retry;
2718     case '\r':
2719 #ifdef PERL_STRICT_CR
2720         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2721         Perl_croak(aTHX_
2722       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2723 #endif
2724     case ' ': case '\t': case '\f': case 013:
2725 #ifdef MACOS_TRADITIONAL
2726     case '\312':
2727 #endif
2728         s++;
2729         goto retry;
2730     case '#':
2731     case '\n':
2732         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2733             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2734                 /* handle eval qq[#line 1 "foo"\n ...] */
2735                 CopLINE_dec(PL_curcop);
2736                 incline(s);
2737             }
2738             d = PL_bufend;
2739             while (s < d && *s != '\n')
2740                 s++;
2741             if (s < d)
2742                 s++;
2743             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2744               Perl_croak(aTHX_ "panic: input overflow");
2745             incline(s);
2746             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2747                 PL_bufptr = s;
2748                 PL_lex_state = LEX_FORMLINE;
2749                 return yylex();
2750             }
2751         }
2752         else {
2753             *s = '\0';
2754             PL_bufend = s;
2755         }
2756         goto retry;
2757     case '-':
2758         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2759             I32 ftst = 0;
2760
2761             s++;
2762             PL_bufptr = s;
2763             tmp = *s++;
2764
2765             while (s < PL_bufend && SPACE_OR_TAB(*s))
2766                 s++;
2767
2768             if (strnEQ(s,"=>",2)) {
2769                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2770                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2771                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2772                 } );
2773                 OPERATOR('-');          /* unary minus */
2774             }
2775             PL_last_uni = PL_oldbufptr;
2776             switch (tmp) {
2777             case 'r': ftst = OP_FTEREAD;        break;
2778             case 'w': ftst = OP_FTEWRITE;       break;
2779             case 'x': ftst = OP_FTEEXEC;        break;
2780             case 'o': ftst = OP_FTEOWNED;       break;
2781             case 'R': ftst = OP_FTRREAD;        break;
2782             case 'W': ftst = OP_FTRWRITE;       break;
2783             case 'X': ftst = OP_FTREXEC;        break;
2784             case 'O': ftst = OP_FTROWNED;       break;
2785             case 'e': ftst = OP_FTIS;           break;
2786             case 'z': ftst = OP_FTZERO;         break;
2787             case 's': ftst = OP_FTSIZE;         break;
2788             case 'f': ftst = OP_FTFILE;         break;
2789             case 'd': ftst = OP_FTDIR;          break;
2790             case 'l': ftst = OP_FTLINK;         break;
2791             case 'p': ftst = OP_FTPIPE;         break;
2792             case 'S': ftst = OP_FTSOCK;         break;
2793             case 'u': ftst = OP_FTSUID;         break;
2794             case 'g': ftst = OP_FTSGID;         break;
2795             case 'k': ftst = OP_FTSVTX;         break;
2796             case 'b': ftst = OP_FTBLK;          break;
2797             case 'c': ftst = OP_FTCHR;          break;
2798             case 't': ftst = OP_FTTTY;          break;
2799             case 'T': ftst = OP_FTTEXT;         break;
2800             case 'B': ftst = OP_FTBINARY;       break;
2801             case 'M': case 'A': case 'C':
2802                 gv_fetchpv("\024",TRUE, SVt_PV);
2803                 switch (tmp) {
2804                 case 'M': ftst = OP_FTMTIME;    break;
2805                 case 'A': ftst = OP_FTATIME;    break;
2806                 case 'C': ftst = OP_FTCTIME;    break;
2807                 default:                        break;
2808                 }
2809                 break;
2810             default:
2811                 break;
2812             }
2813             if (ftst) {
2814                 PL_last_lop_op = ftst;
2815                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2816                         "### Saw file test %c\n", (int)ftst);
2817                 } );
2818                 FTST(ftst);
2819             }
2820             else {
2821                 /* Assume it was a minus followed by a one-letter named
2822                  * subroutine call (or a -bareword), then. */
2823                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2824                         "### %c looked like a file test but was not\n",
2825                         (int)ftst);
2826                 } );
2827                 s -= 2;
2828             }
2829         }
2830         tmp = *s++;
2831         if (*s == tmp) {
2832             s++;
2833             if (PL_expect == XOPERATOR)
2834                 TERM(POSTDEC);
2835             else
2836                 OPERATOR(PREDEC);
2837         }
2838         else if (*s == '>') {
2839             s++;
2840             s = skipspace(s);
2841             if (isIDFIRST_lazy_if(s,UTF)) {
2842                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2843                 TOKEN(ARROW);
2844             }
2845             else if (*s == '$')
2846                 OPERATOR(ARROW);
2847             else
2848                 TERM(ARROW);
2849         }
2850         if (PL_expect == XOPERATOR)
2851             Aop(OP_SUBTRACT);
2852         else {
2853             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2854                 check_uni();
2855             OPERATOR('-');              /* unary minus */
2856         }
2857
2858     case '+':
2859         tmp = *s++;
2860         if (*s == tmp) {
2861             s++;
2862             if (PL_expect == XOPERATOR)
2863                 TERM(POSTINC);
2864             else
2865                 OPERATOR(PREINC);
2866         }
2867         if (PL_expect == XOPERATOR)
2868             Aop(OP_ADD);
2869         else {
2870             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2871                 check_uni();
2872             OPERATOR('+');
2873         }
2874
2875     case '*':
2876         if (PL_expect != XOPERATOR) {
2877             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2878             PL_expect = XOPERATOR;
2879             force_ident(PL_tokenbuf, '*');
2880             if (!*PL_tokenbuf)
2881                 PREREF('*');
2882             TERM('*');
2883         }
2884         s++;
2885         if (*s == '*') {
2886             s++;
2887             PWop(OP_POW);
2888         }
2889         Mop(OP_MULTIPLY);
2890
2891     case '%':
2892         if (PL_expect == XOPERATOR) {
2893             ++s;
2894             Mop(OP_MODULO);
2895         }
2896         PL_tokenbuf[0] = '%';
2897         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2898         if (!PL_tokenbuf[1]) {
2899             if (s == PL_bufend)
2900                 yyerror("Final % should be \\% or %name");
2901             PREREF('%');
2902         }
2903         PL_pending_ident = '%';
2904         TERM('%');
2905
2906     case '^':
2907         s++;
2908         BOop(OP_BIT_XOR);
2909     case '[':
2910         PL_lex_brackets++;
2911         /* FALL THROUGH */
2912     case '~':
2913     case ',':
2914         tmp = *s++;
2915         OPERATOR(tmp);
2916     case ':':
2917         if (s[1] == ':') {
2918             len = 0;
2919             goto just_a_word;
2920         }
2921         s++;
2922         switch (PL_expect) {
2923             OP *attrs;
2924         case XOPERATOR:
2925             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2926                 break;
2927             PL_bufptr = s;      /* update in case we back off */
2928             goto grabattrs;
2929         case XATTRBLOCK:
2930             PL_expect = XBLOCK;
2931             goto grabattrs;
2932         case XATTRTERM:
2933             PL_expect = XTERMBLOCK;
2934          grabattrs:
2935             s = skipspace(s);
2936             attrs = Nullop;
2937             while (isIDFIRST_lazy_if(s,UTF)) {
2938                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2939                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2940                     if (tmp < 0) tmp = -tmp;
2941                     switch (tmp) {
2942                     case KEY_or:
2943                     case KEY_and:
2944                     case KEY_for:
2945                     case KEY_unless:
2946                     case KEY_if:
2947                     case KEY_while:
2948                     case KEY_until:
2949                         goto got_attrs;
2950                     default:
2951                         break;
2952                     }
2953                 }
2954                 if (*d == '(') {
2955                     d = scan_str(d,TRUE,TRUE);
2956                     if (!d) {
2957                         /* MUST advance bufptr here to avoid bogus
2958                            "at end of line" context messages from yyerror().
2959                          */
2960                         PL_bufptr = s + len;
2961                         yyerror("Unterminated attribute parameter in attribute list");
2962                         if (attrs)
2963                             op_free(attrs);
2964                         return 0;       /* EOF indicator */
2965                     }
2966                 }
2967                 if (PL_lex_stuff) {
2968                     SV *sv = newSVpvn(s, len);
2969                     sv_catsv(sv, PL_lex_stuff);
2970                     attrs = append_elem(OP_LIST, attrs,
2971                                         newSVOP(OP_CONST, 0, sv));
2972                     SvREFCNT_dec(PL_lex_stuff);
2973                     PL_lex_stuff = Nullsv;
2974                 }
2975                 else {
2976                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2977                         CvLVALUE_on(PL_compcv);
2978                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2979                         CvLOCKED_on(PL_compcv);
2980                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2981                         CvMETHOD_on(PL_compcv);
2982 #ifdef USE_ITHREADS
2983       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2984                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2985 #endif
2986                     /* After we've set the flags, it could be argued that
2987                        we don't need to do the attributes.pm-based setting
2988                        process, and shouldn't bother appending recognized
2989                        flags. To experiment with that, uncomment the
2990                        following "else": */
2991                     else
2992                         attrs = append_elem(OP_LIST, attrs,
2993                                             newSVOP(OP_CONST, 0,
2994                                                     newSVpvn(s, len)));
2995                 }
2996                 s = skipspace(d);
2997                 if (*s == ':' && s[1] != ':')
2998                     s = skipspace(s+1);
2999                 else if (s == d)
3000                     break;      /* require real whitespace or :'s */
3001             }
3002             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3003             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3004                 char q = ((*s == '\'') ? '"' : '\'');
3005                 /* If here for an expression, and parsed no attrs, back off. */
3006                 if (tmp == '=' && !attrs) {
3007                     s = PL_bufptr;
3008                     break;
3009                 }
3010                 /* MUST advance bufptr here to avoid bogus "at end of line"
3011                    context messages from yyerror().
3012                  */
3013                 PL_bufptr = s;
3014                 if (!*s)
3015                     yyerror("Unterminated attribute list");
3016                 else
3017                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3018                                       q, *s, q));
3019                 if (attrs)
3020                     op_free(attrs);
3021                 OPERATOR(':');
3022             }
3023         got_attrs:
3024             if (attrs) {
3025                 PL_nextval[PL_nexttoke].opval = attrs;
3026                 force_next(THING);
3027             }
3028             TOKEN(COLONATTR);
3029         }
3030         OPERATOR(':');
3031     case '(':
3032         s++;
3033         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3034             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3035         else
3036             PL_expect = XTERM;
3037         TOKEN('(');
3038     case ';':
3039         CLINE;
3040         tmp = *s++;
3041         OPERATOR(tmp);
3042     case ')':
3043         tmp = *s++;
3044         s = skipspace(s);
3045         if (*s == '{')
3046             PREBLOCK(tmp);
3047         TERM(tmp);
3048     case ']':
3049         s++;
3050         if (PL_lex_brackets <= 0)
3051             yyerror("Unmatched right square bracket");
3052         else
3053             --PL_lex_brackets;
3054         if (PL_lex_state == LEX_INTERPNORMAL) {
3055             if (PL_lex_brackets == 0) {
3056                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3057                     PL_lex_state = LEX_INTERPEND;
3058             }
3059         }
3060         TERM(']');
3061     case '{':
3062       leftbracket:
3063         s++;
3064         if (PL_lex_brackets > 100) {
3065             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3066             if (newlb != PL_lex_brackstack) {
3067                 SAVEFREEPV(newlb);
3068                 PL_lex_brackstack = newlb;
3069             }
3070         }
3071         switch (PL_expect) {
3072         case XTERM:
3073             if (PL_lex_formbrack) {
3074                 s--;
3075                 PRETERMBLOCK(DO);
3076             }
3077             if (PL_oldoldbufptr == PL_last_lop)
3078                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3079             else
3080                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3081             OPERATOR(HASHBRACK);
3082         case XOPERATOR:
3083             while (s < PL_bufend && SPACE_OR_TAB(*s))
3084                 s++;
3085             d = s;
3086             PL_tokenbuf[0] = '\0';
3087             if (d < PL_bufend && *d == '-') {
3088                 PL_tokenbuf[0] = '-';
3089                 d++;
3090                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3091                     d++;
3092             }
3093             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3094                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3095                               FALSE, &len);
3096                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3097                     d++;
3098                 if (*d == '}') {
3099                     char minus = (PL_tokenbuf[0] == '-');
3100                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3101                     if (minus)
3102                         force_next('-');
3103                 }
3104             }
3105             /* FALL THROUGH */
3106         case XATTRBLOCK:
3107         case XBLOCK:
3108             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3109             PL_expect = XSTATE;
3110             break;
3111         case XATTRTERM:
3112         case XTERMBLOCK:
3113             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3114             PL_expect = XSTATE;
3115             break;
3116         default: {
3117                 char *t;
3118                 if (PL_oldoldbufptr == PL_last_lop)
3119                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3120                 else
3121                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3122                 s = skipspace(s);
3123                 if (*s == '}') {
3124                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3125                         PL_expect = XTERM;
3126                         /* This hack is to get the ${} in the message. */
3127                         PL_bufptr = s+1;
3128                         yyerror("syntax error");
3129                         break;
3130                     }
3131                     OPERATOR(HASHBRACK);
3132                 }
3133                 /* This hack serves to disambiguate a pair of curlies
3134                  * as being a block or an anon hash.  Normally, expectation
3135                  * determines that, but in cases where we're not in a
3136                  * position to expect anything in particular (like inside
3137                  * eval"") we have to resolve the ambiguity.  This code
3138                  * covers the case where the first term in the curlies is a
3139                  * quoted string.  Most other cases need to be explicitly
3140                  * disambiguated by prepending a `+' before the opening
3141                  * curly in order to force resolution as an anon hash.
3142                  *
3143                  * XXX should probably propagate the outer expectation
3144                  * into eval"" to rely less on this hack, but that could
3145                  * potentially break current behavior of eval"".
3146                  * GSAR 97-07-21
3147                  */
3148                 t = s;
3149                 if (*s == '\'' || *s == '"' || *s == '`') {
3150                     /* common case: get past first string, handling escapes */
3151                     for (t++; t < PL_bufend && *t != *s;)
3152                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3153                             t++;
3154                     t++;
3155                 }
3156                 else if (*s == 'q') {
3157                     if (++t < PL_bufend
3158                         && (!isALNUM(*t)
3159                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3160                                 && !isALNUM(*t))))
3161                     {
3162                         char *tmps;
3163                         char open, close, term;
3164                         I32 brackets = 1;
3165
3166                         while (t < PL_bufend && isSPACE(*t))
3167                             t++;
3168                         term = *t;
3169                         open = term;
3170                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3171                             term = tmps[5];
3172                         close = term;
3173                         if (open == close)
3174                             for (t++; t < PL_bufend; t++) {
3175                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3176                                     t++;
3177                                 else if (*t == open)
3178                                     break;
3179                             }
3180                         else
3181                             for (t++; t < PL_bufend; t++) {
3182                                 if (*t == '\\' && t+1 < PL_bufend)
3183                                     t++;
3184                                 else if (*t == close && --brackets <= 0)
3185                                     break;
3186                                 else if (*t == open)
3187                                     brackets++;
3188                             }
3189                     }
3190                     t++;
3191                 }
3192                 else if (isALNUM_lazy_if(t,UTF)) {
3193                     t += UTF8SKIP(t);
3194                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3195                          t += UTF8SKIP(t);
3196                 }
3197                 while (t < PL_bufend && isSPACE(*t))
3198                     t++;
3199                 /* if comma follows first term, call it an anon hash */
3200                 /* XXX it could be a comma expression with loop modifiers */
3201                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3202                                    || (*t == '=' && t[1] == '>')))
3203                     OPERATOR(HASHBRACK);
3204                 if (PL_expect == XREF)
3205                     PL_expect = XTERM;
3206                 else {
3207                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3208                     PL_expect = XSTATE;
3209                 }
3210             }
3211             break;
3212         }
3213         yylval.ival = CopLINE(PL_curcop);
3214         if (isSPACE(*s) || *s == '#')
3215             PL_copline = NOLINE;   /* invalidate current command line number */
3216         TOKEN('{');
3217     case '}':
3218       rightbracket:
3219         s++;
3220         if (PL_lex_brackets <= 0)
3221             yyerror("Unmatched right curly bracket");
3222         else
3223             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3224         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3225             PL_lex_formbrack = 0;
3226         if (PL_lex_state == LEX_INTERPNORMAL) {
3227             if (PL_lex_brackets == 0) {
3228                 if (PL_expect & XFAKEBRACK) {
3229                     PL_expect &= XENUMMASK;
3230                     PL_lex_state = LEX_INTERPEND;
3231                     PL_bufptr = s;
3232                     return yylex();     /* ignore fake brackets */
3233                 }
3234                 if (*s == '-' && s[1] == '>')
3235                     PL_lex_state = LEX_INTERPENDMAYBE;
3236                 else if (*s != '[' && *s != '{')
3237                     PL_lex_state = LEX_INTERPEND;
3238             }
3239         }
3240         if (PL_expect & XFAKEBRACK) {
3241             PL_expect &= XENUMMASK;
3242             PL_bufptr = s;
3243             return yylex();             /* ignore fake brackets */
3244         }
3245         force_next('}');
3246         TOKEN(';');
3247     case '&':
3248         s++;
3249         tmp = *s++;
3250         if (tmp == '&')
3251             AOPERATOR(ANDAND);
3252         s--;
3253         if (PL_expect == XOPERATOR) {
3254             if (ckWARN(WARN_SEMICOLON)
3255                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3256             {
3257                 CopLINE_dec(PL_curcop);
3258                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3259                 CopLINE_inc(PL_curcop);
3260             }
3261             BAop(OP_BIT_AND);
3262         }
3263
3264         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3265         if (*PL_tokenbuf) {
3266             PL_expect = XOPERATOR;
3267             force_ident(PL_tokenbuf, '&');
3268         }
3269         else
3270             PREREF('&');
3271         yylval.ival = (OPpENTERSUB_AMPER<<8);
3272         TERM('&');
3273
3274     case '|':
3275         s++;
3276         tmp = *s++;
3277         if (tmp == '|')
3278             AOPERATOR(OROR);
3279         s--;
3280         BOop(OP_BIT_OR);
3281     case '=':
3282         s++;
3283         tmp = *s++;
3284         if (tmp == '=')
3285             Eop(OP_EQ);
3286         if (tmp == '>')
3287             OPERATOR(',');
3288         if (tmp == '~')
3289             PMop(OP_MATCH);
3290         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3291             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3292         s--;
3293         if (PL_expect == XSTATE && isALPHA(tmp) &&
3294                 (s == PL_linestart+1 || s[-2] == '\n') )
3295         {
3296             if (PL_in_eval && !PL_rsfp) {
3297                 d = PL_bufend;
3298                 while (s < d) {
3299                     if (*s++ == '\n') {
3300                         incline(s);
3301                         if (strnEQ(s,"=cut",4)) {
3302                             s = strchr(s,'\n');
3303                             if (s)
3304                                 s++;
3305                             else
3306                                 s = d;
3307                             incline(s);
3308                             goto retry;
3309                         }
3310                     }
3311                 }
3312                 goto retry;
3313             }
3314             s = PL_bufend;
3315             PL_doextract = TRUE;
3316             goto retry;
3317         }
3318         if (PL_lex_brackets < PL_lex_formbrack) {
3319             char *t;
3320 #ifdef PERL_STRICT_CR
3321             for (t = s; SPACE_OR_TAB(*t); t++) ;
3322 #else
3323             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3324 #endif
3325             if (*t == '\n' || *t == '#') {
3326                 s--;
3327                 PL_expect = XBLOCK;
3328                 goto leftbracket;
3329             }
3330         }
3331         yylval.ival = 0;
3332         OPERATOR(ASSIGNOP);
3333     case '!':
3334         s++;
3335         tmp = *s++;
3336         if (tmp == '=')
3337             Eop(OP_NE);
3338         if (tmp == '~')
3339             PMop(OP_NOT);
3340         s--;
3341         OPERATOR('!');
3342     case '<':
3343         if (PL_expect != XOPERATOR) {
3344             if (s[1] != '<' && !strchr(s,'>'))
3345                 check_uni();
3346             if (s[1] == '<')
3347                 s = scan_heredoc(s);
3348             else
3349                 s = scan_inputsymbol(s);
3350             TERM(sublex_start());
3351         }
3352         s++;
3353         tmp = *s++;
3354         if (tmp == '<')
3355             SHop(OP_LEFT_SHIFT);
3356         if (tmp == '=') {
3357             tmp = *s++;
3358             if (tmp == '>')
3359                 Eop(OP_NCMP);
3360             s--;
3361             Rop(OP_LE);
3362         }
3363         s--;
3364         Rop(OP_LT);
3365     case '>':
3366         s++;
3367         tmp = *s++;
3368         if (tmp == '>')
3369             SHop(OP_RIGHT_SHIFT);
3370         if (tmp == '=')
3371             Rop(OP_GE);
3372         s--;
3373         Rop(OP_GT);
3374
3375     case '$':
3376         CLINE;
3377
3378         if (PL_expect == XOPERATOR) {
3379             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3380                 PL_expect = XTERM;
3381                 depcom();
3382                 return ','; /* grandfather non-comma-format format */
3383             }
3384         }
3385
3386         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3387             PL_tokenbuf[0] = '@';
3388             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3389                            sizeof PL_tokenbuf - 1, FALSE);
3390             if (PL_expect == XOPERATOR)
3391                 no_op("Array length", s);
3392             if (!PL_tokenbuf[1])
3393                 PREREF(DOLSHARP);
3394             PL_expect = XOPERATOR;
3395             PL_pending_ident = '#';
3396             TOKEN(DOLSHARP);
3397         }
3398
3399         PL_tokenbuf[0] = '$';
3400         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3401                        sizeof PL_tokenbuf - 1, FALSE);
3402         if (PL_expect == XOPERATOR)
3403             no_op("Scalar", s);
3404         if (!PL_tokenbuf[1]) {
3405             if (s == PL_bufend)
3406                 yyerror("Final $ should be \\$ or $name");
3407             PREREF('$');
3408         }
3409
3410         /* This kludge not intended to be bulletproof. */
3411         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3412             yylval.opval = newSVOP(OP_CONST, 0,
3413                                    newSViv(PL_compiling.cop_arybase));
3414             yylval.opval->op_private = OPpCONST_ARYBASE;
3415             TERM(THING);
3416         }
3417
3418         d = s;
3419         tmp = (I32)*s;
3420         if (PL_lex_state == LEX_NORMAL)
3421             s = skipspace(s);
3422
3423         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3424             char *t;
3425             if (*s == '[') {
3426                 PL_tokenbuf[0] = '@';
3427                 if (ckWARN(WARN_SYNTAX)) {
3428                     for(t = s + 1;
3429                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3430                         t++) ;
3431                     if (*t++ == ',') {
3432                         PL_bufptr = skipspace(PL_bufptr);
3433                         while (t < PL_bufend && *t != ']')
3434                             t++;
3435                         Perl_warner(aTHX_ WARN_SYNTAX,
3436                                 "Multidimensional syntax %.*s not supported",
3437                                 (t - PL_bufptr) + 1, PL_bufptr);
3438                     }
3439                 }
3440             }
3441             else if (*s == '{') {
3442                 PL_tokenbuf[0] = '%';
3443                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3444                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3445                 {
3446                     char tmpbuf[sizeof PL_tokenbuf];
3447                     STRLEN len;
3448                     for (t++; isSPACE(*t); t++) ;
3449                     if (isIDFIRST_lazy_if(t,UTF)) {
3450                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3451                         for (; isSPACE(*t); t++) ;
3452                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3453                             Perl_warner(aTHX_ WARN_SYNTAX,
3454                                 "You need to quote \"%s\"", tmpbuf);
3455                     }
3456                 }
3457             }
3458         }
3459
3460         PL_expect = XOPERATOR;
3461         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3462             bool islop = (PL_last_lop == PL_oldoldbufptr);
3463             if (!islop || PL_last_lop_op == OP_GREPSTART)
3464                 PL_expect = XOPERATOR;
3465             else if (strchr("$@\"'`q", *s))
3466                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3467             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3468                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3469             else if (isIDFIRST_lazy_if(s,UTF)) {
3470                 char tmpbuf[sizeof PL_tokenbuf];
3471                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3472                 if ((tmp = keyword(tmpbuf, len))) {
3473                     /* binary operators exclude handle interpretations */
3474                     switch (tmp) {
3475                     case -KEY_x:
3476                     case -KEY_eq:
3477                     case -KEY_ne:
3478                     case -KEY_gt:
3479                     case -KEY_lt:
3480                     case -KEY_ge:
3481                     case -KEY_le:
3482                     case -KEY_cmp:
3483                         break;
3484                     default:
3485                         PL_expect = XTERM;      /* e.g. print $fh length() */
3486                         break;
3487                     }
3488                 }
3489                 else {
3490                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3491                     if (gv && GvCVu(gv))
3492                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3493                 }
3494             }
3495             else if (isDIGIT(*s))
3496                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3497             else if (*s == '.' && isDIGIT(s[1]))
3498                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3499             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3500                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3501             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3502                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3503         }
3504         PL_pending_ident = '$';
3505         TOKEN('$');
3506
3507     case '@':
3508         if (PL_expect == XOPERATOR)
3509             no_op("Array", s);
3510         PL_tokenbuf[0] = '@';
3511         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3512         if (!PL_tokenbuf[1]) {
3513             if (s == PL_bufend)
3514                 yyerror("Final @ should be \\@ or @name");
3515             PREREF('@');
3516         }
3517         if (PL_lex_state == LEX_NORMAL)
3518             s = skipspace(s);
3519         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3520             if (*s == '{')
3521                 PL_tokenbuf[0] = '%';
3522
3523             /* Warn about @ where they meant $. */
3524             if (ckWARN(WARN_SYNTAX)) {
3525                 if (*s == '[' || *s == '{') {
3526                     char *t = s + 1;
3527                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3528                         t++;
3529                     if (*t == '}' || *t == ']') {
3530                         t++;
3531                         PL_bufptr = skipspace(PL_bufptr);
3532                         Perl_warner(aTHX_ WARN_SYNTAX,
3533                             "Scalar value %.*s better written as $%.*s",
3534                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3535                     }
3536                 }
3537             }
3538         }
3539         PL_pending_ident = '@';
3540         TERM('@');
3541
3542     case '/':                   /* may either be division or pattern */
3543     case '?':                   /* may either be conditional or pattern */
3544         if (PL_expect != XOPERATOR) {
3545             /* Disable warning on "study /blah/" */
3546             if (PL_oldoldbufptr == PL_last_uni
3547                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3548                     || memNE(PL_last_uni, "study", 5)
3549                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3550                 check_uni();
3551             s = scan_pat(s,OP_MATCH);
3552             TERM(sublex_start());
3553         }
3554         tmp = *s++;
3555         if (tmp == '/')
3556             Mop(OP_DIVIDE);
3557         OPERATOR(tmp);
3558
3559     case '.':
3560         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3561 #ifdef PERL_STRICT_CR
3562             && s[1] == '\n'
3563 #else
3564             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3565 #endif
3566             && (s == PL_linestart || s[-1] == '\n') )
3567         {
3568             PL_lex_formbrack = 0;
3569             PL_expect = XSTATE;
3570             goto rightbracket;
3571         }
3572         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3573             tmp = *s++;
3574             if (*s == tmp) {
3575                 s++;
3576                 if (*s == tmp) {
3577                     s++;
3578                     yylval.ival = OPf_SPECIAL;
3579                 }
3580                 else
3581                     yylval.ival = 0;
3582                 OPERATOR(DOTDOT);
3583             }
3584             if (PL_expect != XOPERATOR)
3585                 check_uni();
3586             Aop(OP_CONCAT);
3587         }
3588         /* FALL THROUGH */
3589     case '0': case '1': case '2': case '3': case '4':
3590     case '5': case '6': case '7': case '8': case '9':
3591         s = scan_num(s, &yylval);
3592         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3593                     "### Saw number in '%s'\n", s);
3594         } );
3595         if (PL_expect == XOPERATOR)
3596             no_op("Number",s);
3597         TERM(THING);
3598
3599     case '\'':
3600         s = scan_str(s,FALSE,FALSE);
3601         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3602                     "### Saw string before '%s'\n", s);
3603         } );
3604         if (PL_expect == XOPERATOR) {
3605             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3606                 PL_expect = XTERM;
3607                 depcom();
3608                 return ',';     /* grandfather non-comma-format format */
3609             }
3610             else
3611                 no_op("String",s);
3612         }
3613         if (!s)
3614             missingterm((char*)0);
3615         yylval.ival = OP_CONST;
3616         TERM(sublex_start());
3617
3618     case '"':
3619         s = scan_str(s,FALSE,FALSE);
3620         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3621                     "### Saw string before '%s'\n", s);
3622         } );
3623         if (PL_expect == XOPERATOR) {
3624             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3625                 PL_expect = XTERM;
3626                 depcom();
3627                 return ',';     /* grandfather non-comma-format format */
3628             }
3629             else
3630                 no_op("String",s);
3631         }
3632         if (!s)
3633             missingterm((char*)0);
3634         yylval.ival = OP_CONST;
3635         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3636             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3637                 yylval.ival = OP_STRINGIFY;
3638                 break;
3639             }
3640         }
3641         TERM(sublex_start());
3642
3643     case '`':
3644         s = scan_str(s,FALSE,FALSE);
3645         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3646                     "### Saw backtick string before '%s'\n", s);
3647         } );
3648         if (PL_expect == XOPERATOR)
3649             no_op("Backticks",s);
3650         if (!s)
3651             missingterm((char*)0);
3652         yylval.ival = OP_BACKTICK;
3653         set_csh();
3654         TERM(sublex_start());
3655
3656     case '\\':
3657         s++;
3658         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3659             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3660                         *s, *s);
3661         if (PL_expect == XOPERATOR)
3662             no_op("Backslash",s);
3663         OPERATOR(REFGEN);
3664
3665     case 'v':
3666         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3667             char *start = s;
3668             start++;
3669             start++;
3670             while (isDIGIT(*start) || *start == '_')
3671                 start++;
3672             if (*start == '.' && isDIGIT(start[1])) {
3673                 s = scan_num(s, &yylval);
3674                 TERM(THING);
3675             }
3676             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3677             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3678                 char c = *start;
3679                 GV *gv;
3680                 *start = '\0';
3681                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3682                 *start = c;
3683                 if (!gv) {
3684                     s = scan_num(s, &yylval);
3685                     TERM(THING);
3686                 }
3687             }
3688         }
3689         goto keylookup;
3690     case 'x':
3691         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3692             s++;
3693             Mop(OP_REPEAT);
3694         }
3695         goto keylookup;
3696
3697     case '_':
3698     case 'a': case 'A':
3699     case 'b': case 'B':
3700     case 'c': case 'C':
3701     case 'd': case 'D':
3702     case 'e': case 'E':
3703     case 'f': case 'F':
3704     case 'g': case 'G':
3705     case 'h': case 'H':
3706     case 'i': case 'I':
3707     case 'j': case 'J':
3708     case 'k': case 'K':
3709     case 'l': case 'L':
3710     case 'm': case 'M':
3711     case 'n': case 'N':
3712     case 'o': case 'O':
3713     case 'p': case 'P':
3714     case 'q': case 'Q':
3715     case 'r': case 'R':
3716     case 's': case 'S':
3717     case 't': case 'T':
3718     case 'u': case 'U':
3719               case 'V':
3720     case 'w': case 'W':
3721               case 'X':
3722     case 'y': case 'Y':
3723     case 'z': case 'Z':
3724
3725       keylookup: {
3726         gv = Nullgv;
3727         gvp = 0;
3728
3729         PL_bufptr = s;
3730         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3731
3732         /* Some keywords can be followed by any delimiter, including ':' */
3733         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3734                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3735                              (PL_tokenbuf[0] == 'q' &&
3736                               strchr("qwxr", PL_tokenbuf[1])))));
3737
3738         /* x::* is just a word, unless x is "CORE" */
3739         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3740             goto just_a_word;
3741
3742         d = s;
3743         while (d < PL_bufend && isSPACE(*d))
3744                 d++;    /* no comments skipped here, or s### is misparsed */
3745
3746         /* Is this a label? */
3747         if (!tmp && PL_expect == XSTATE
3748               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3749             s = d + 1;
3750             yylval.pval = savepv(PL_tokenbuf);
3751             CLINE;
3752             TOKEN(LABEL);
3753         }
3754
3755         /* Check for keywords */
3756         tmp = keyword(PL_tokenbuf, len);
3757
3758         /* Is this a word before a => operator? */
3759         if (*d == '=' && d[1] == '>') {
3760             CLINE;
3761             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3762             yylval.opval->op_private = OPpCONST_BARE;
3763             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3764               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3765             TERM(WORD);
3766         }
3767
3768         if (tmp < 0) {                  /* second-class keyword? */
3769             GV *ogv = Nullgv;   /* override (winner) */
3770             GV *hgv = Nullgv;   /* hidden (loser) */
3771             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3772                 CV *cv;
3773                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3774                     (cv = GvCVu(gv)))
3775                 {
3776                     if (GvIMPORTED_CV(gv))
3777                         ogv = gv;
3778                     else if (! CvMETHOD(cv))
3779                         hgv = gv;
3780                 }
3781                 if (!ogv &&
3782                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3783                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3784                     GvCVu(gv) && GvIMPORTED_CV(gv))
3785                 {
3786                     ogv = gv;
3787                 }
3788             }
3789             if (ogv) {
3790                 tmp = 0;                /* overridden by import or by GLOBAL */
3791             }
3792             else if (gv && !gvp
3793                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3794                      && GvCVu(gv)
3795                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3796             {
3797                 tmp = 0;                /* any sub overrides "weak" keyword */
3798             }
3799             else {                      /* no override */
3800                 tmp = -tmp;
3801                 gv = Nullgv;
3802                 gvp = 0;
3803                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3804                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3805                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3806                         "Ambiguous call resolved as CORE::%s(), %s",
3807                          GvENAME(hgv), "qualify as such or use &");
3808             }
3809         }
3810
3811       reserved_word:
3812         switch (tmp) {
3813
3814         default:                        /* not a keyword */
3815           just_a_word: {
3816                 SV *sv;
3817                 int pkgname = 0;
3818                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3819
3820                 /* Get the rest if it looks like a package qualifier */
3821
3822                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3823                     STRLEN morelen;
3824                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3825                                   TRUE, &morelen);
3826                     if (!morelen)
3827                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3828                                 *s == '\'' ? "'" : "::");
3829                     len += morelen;
3830                     pkgname = 1;
3831                 }
3832
3833                 if (PL_expect == XOPERATOR) {
3834                     if (PL_bufptr == PL_linestart) {
3835                         CopLINE_dec(PL_curcop);
3836                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3837                         CopLINE_inc(PL_curcop);
3838                     }
3839                     else
3840                         no_op("Bareword",s);
3841                 }
3842
3843                 /* Look for a subroutine with this name in current package,
3844                    unless name is "Foo::", in which case Foo is a bearword
3845                    (and a package name). */
3846
3847                 if (len > 2 &&
3848                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3849                 {
3850                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3851                         Perl_warner(aTHX_ WARN_BAREWORD,
3852                             "Bareword \"%s\" refers to nonexistent package",
3853                              PL_tokenbuf);
3854                     len -= 2;
3855                     PL_tokenbuf[len] = '\0';
3856                     gv = Nullgv;
3857                     gvp = 0;
3858                 }
3859                 else {
3860                     len = 0;
3861                     if (!gv)
3862                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3863                 }
3864
3865                 /* if we saw a global override before, get the right name */
3866
3867                 if (gvp) {
3868                     sv = newSVpvn("CORE::GLOBAL::",14);
3869                     sv_catpv(sv,PL_tokenbuf);
3870                 }
3871                 else
3872                     sv = newSVpv(PL_tokenbuf,0);
3873
3874                 /* Presume this is going to be a bareword of some sort. */
3875
3876                 CLINE;
3877                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3878                 yylval.opval->op_private = OPpCONST_BARE;
3879
3880                 /* And if "Foo::", then that's what it certainly is. */
3881
3882                 if (len)
3883                     goto safe_bareword;
3884
3885                 /* See if it's the indirect object for a list operator. */
3886
3887                 if (PL_oldoldbufptr &&
3888                     PL_oldoldbufptr < PL_bufptr &&
3889                     (PL_oldoldbufptr == PL_last_lop
3890                      || PL_oldoldbufptr == PL_last_uni) &&
3891                     /* NO SKIPSPACE BEFORE HERE! */
3892                     (PL_expect == XREF ||
3893                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3894                 {
3895                     bool immediate_paren = *s == '(';
3896
3897                     /* (Now we can afford to cross potential line boundary.) */
3898                     s = skipspace(s);
3899
3900                     /* Two barewords in a row may indicate method call. */
3901
3902                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3903                         return tmp;
3904
3905                     /* If not a declared subroutine, it's an indirect object. */
3906                     /* (But it's an indir obj regardless for sort.) */
3907
3908                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3909                          ((!gv || !GvCVu(gv)) &&
3910                         (PL_last_lop_op != OP_MAPSTART &&
3911                          PL_last_lop_op != OP_GREPSTART))))
3912                     {
3913                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3914                         goto bareword;
3915                     }
3916                 }
3917
3918                 PL_expect = XOPERATOR;
3919                 s = skipspace(s);
3920
3921                 /* Is this a word before a => operator? */
3922                 if (*s == '=' && s[1] == '>' && !pkgname) {
3923                     CLINE;
3924                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3925                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3926                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3927                     TERM(WORD);
3928                 }
3929
3930                 /* If followed by a paren, it's certainly a subroutine. */
3931                 if (*s == '(') {
3932                     CLINE;
3933                     if (gv && GvCVu(gv)) {
3934                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3935                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3936                             s = d + 1;
3937                             goto its_constant;
3938                         }
3939                     }
3940                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3941                     PL_expect = XOPERATOR;
3942                     force_next(WORD);
3943                     yylval.ival = 0;
3944                     TOKEN('&');
3945                 }
3946
3947                 /* If followed by var or block, call it a method (unless sub) */
3948
3949                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3950                     PL_last_lop = PL_oldbufptr;
3951                     PL_last_lop_op = OP_METHOD;
3952                     PREBLOCK(METHOD);
3953                 }
3954
3955                 /* If followed by a bareword, see if it looks like indir obj. */
3956
3957                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3958                     return tmp;
3959
3960                 /* Not a method, so call it a subroutine (if defined) */
3961
3962                 if (gv && GvCVu(gv)) {
3963                     CV* cv;
3964                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3965                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3966                                 "Ambiguous use of -%s resolved as -&%s()",
3967                                 PL_tokenbuf, PL_tokenbuf);
3968                     /* Check for a constant sub */
3969                     cv = GvCV(gv);
3970                     if ((sv = cv_const_sv(cv))) {
3971                   its_constant:
3972                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3973                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3974                         yylval.opval->op_private = 0;
3975                         TOKEN(WORD);
3976                     }
3977
3978                     /* Resolve to GV now. */
3979                     op_free(yylval.opval);
3980                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3981                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3982                     PL_last_lop = PL_oldbufptr;
3983                     PL_last_lop_op = OP_ENTERSUB;
3984                     /* Is there a prototype? */
3985                     if (SvPOK(cv)) {
3986                         STRLEN len;
3987                         char *proto = SvPV((SV*)cv, len);
3988                         if (!len)
3989                             TERM(FUNC0SUB);
3990                         if (strEQ(proto, "$"))
3991                             OPERATOR(UNIOPSUB);
3992                         if (*proto == '&' && *s == '{') {
3993                             sv_setpv(PL_subname,"__ANON__");
3994                             PREBLOCK(LSTOPSUB);
3995                         }
3996                     }
3997                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3998                     PL_expect = XTERM;
3999                     force_next(WORD);
4000                     TOKEN(NOAMP);
4001                 }
4002
4003                 /* Call it a bare word */
4004
4005                 if (PL_hints & HINT_STRICT_SUBS)
4006                     yylval.opval->op_private |= OPpCONST_STRICT;
4007                 else {
4008                 bareword:
4009                     if (ckWARN(WARN_RESERVED)) {
4010                         if (lastchar != '-') {
4011                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4012                             if (!*d && strNE(PL_tokenbuf,"main"))
4013                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4014                                        PL_tokenbuf);
4015                         }
4016                     }
4017                 }
4018
4019             safe_bareword:
4020                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4021                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4022                         "Operator or semicolon missing before %c%s",
4023                         lastchar, PL_tokenbuf);
4024                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4025                         "Ambiguous use of %c resolved as operator %c",
4026                         lastchar, lastchar);
4027                 }
4028                 TOKEN(WORD);
4029             }
4030
4031         case KEY___FILE__:
4032             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4033                                         newSVpv(CopFILE(PL_curcop),0));
4034             TERM(THING);
4035
4036         case KEY___LINE__:
4037             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4038                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4039             TERM(THING);
4040
4041         case KEY___PACKAGE__:
4042             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4043                                         (PL_curstash
4044                                          ? newSVsv(PL_curstname)
4045                                          : &PL_sv_undef));
4046             TERM(THING);
4047
4048         case KEY___DATA__:
4049         case KEY___END__: {
4050             GV *gv;
4051
4052             /*SUPPRESS 560*/
4053             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4054                 char *pname = "main";
4055                 if (PL_tokenbuf[2] == 'D')
4056                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4057                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4058                 GvMULTI_on(gv);
4059                 if (!GvIO(gv))
4060                     GvIOp(gv) = newIO();
4061                 IoIFP(GvIOp(gv)) = PL_rsfp;
4062 #if defined(HAS_FCNTL) && defined(F_SETFD)
4063                 {
4064                     int fd = PerlIO_fileno(PL_rsfp);
4065                     fcntl(fd,F_SETFD,fd >= 3);
4066                 }
4067 #endif
4068                 /* Mark this internal pseudo-handle as clean */
4069                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4070                 if (PL_preprocess)
4071                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4072                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4073                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4074                 else
4075                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4076 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4077                 /* if the script was opened in binmode, we need to revert
4078                  * it to text mode for compatibility; but only iff it has CRs
4079                  * XXX this is a questionable hack at best. */
4080                 if (PL_bufend-PL_bufptr > 2
4081                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4082                 {
4083                     Off_t loc = 0;
4084                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4085                         loc = PerlIO_tell(PL_rsfp);
4086                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4087                     }
4088 #ifdef NETWARE
4089                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4090 #else
4091                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4092 #endif  /* NETWARE */
4093 #ifdef PERLIO_IS_STDIO /* really? */
4094 #  if defined(__BORLANDC__)
4095                         /* XXX see note in do_binmode() */
4096                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4097 #  endif
4098 #endif
4099                         if (loc > 0)
4100                             PerlIO_seek(PL_rsfp, loc, 0);
4101                     }
4102                 }
4103 #endif
4104 #ifdef PERLIO_LAYERS
4105                 if (UTF && !IN_BYTES)
4106                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4107 #endif
4108                 PL_rsfp = Nullfp;
4109             }
4110             goto fake_eof;
4111         }
4112
4113         case KEY_AUTOLOAD:
4114         case KEY_DESTROY:
4115         case KEY_BEGIN:
4116         case KEY_CHECK:
4117         case KEY_INIT:
4118         case KEY_END:
4119             if (PL_expect == XSTATE) {
4120                 s = PL_bufptr;
4121                 goto really_sub;
4122             }
4123             goto just_a_word;
4124
4125         case KEY_CORE:
4126             if (*s == ':' && s[1] == ':') {
4127                 s += 2;
4128                 d = s;
4129                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4130                 if (!(tmp = keyword(PL_tokenbuf, len)))
4131                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4132                 if (tmp < 0)
4133                     tmp = -tmp;
4134                 goto reserved_word;
4135             }
4136             goto just_a_word;
4137
4138         case KEY_abs:
4139             UNI(OP_ABS);
4140
4141         case KEY_alarm:
4142             UNI(OP_ALARM);
4143
4144         case KEY_accept:
4145             LOP(OP_ACCEPT,XTERM);
4146
4147         case KEY_and:
4148             OPERATOR(ANDOP);
4149
4150         case KEY_atan2:
4151             LOP(OP_ATAN2,XTERM);
4152
4153         case KEY_bind:
4154             LOP(OP_BIND,XTERM);
4155
4156         case KEY_binmode:
4157             LOP(OP_BINMODE,XTERM);
4158
4159         case KEY_bless:
4160             LOP(OP_BLESS,XTERM);
4161
4162         case KEY_chop:
4163             UNI(OP_CHOP);
4164
4165         case KEY_continue:
4166             PREBLOCK(CONTINUE);
4167
4168         case KEY_chdir:
4169             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4170             UNI(OP_CHDIR);
4171
4172         case KEY_close:
4173             UNI(OP_CLOSE);
4174
4175         case KEY_closedir:
4176             UNI(OP_CLOSEDIR);
4177
4178         case KEY_cmp:
4179             Eop(OP_SCMP);
4180
4181         case KEY_caller:
4182             UNI(OP_CALLER);
4183
4184         case KEY_crypt:
4185 #ifdef FCRYPT
4186             if (!PL_cryptseen) {
4187                 PL_cryptseen = TRUE;
4188                 init_des();
4189             }
4190 #endif
4191             LOP(OP_CRYPT,XTERM);
4192
4193         case KEY_chmod:
4194             LOP(OP_CHMOD,XTERM);
4195
4196         case KEY_chown:
4197             LOP(OP_CHOWN,XTERM);
4198
4199         case KEY_connect:
4200             LOP(OP_CONNECT,XTERM);
4201
4202         case KEY_chr:
4203             UNI(OP_CHR);
4204
4205         case KEY_cos:
4206             UNI(OP_COS);
4207
4208         case KEY_chroot:
4209             UNI(OP_CHROOT);
4210
4211         case KEY_do:
4212             s = skipspace(s);
4213             if (*s == '{')
4214                 PRETERMBLOCK(DO);
4215             if (*s != '\'')
4216                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4217             OPERATOR(DO);
4218
4219         case KEY_die:
4220             PL_hints |= HINT_BLOCK_SCOPE;
4221             LOP(OP_DIE,XTERM);
4222
4223         case KEY_defined:
4224             UNI(OP_DEFINED);
4225
4226         case KEY_delete:
4227             UNI(OP_DELETE);
4228
4229         case KEY_dbmopen:
4230             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4231             LOP(OP_DBMOPEN,XTERM);
4232
4233         case KEY_dbmclose:
4234             UNI(OP_DBMCLOSE);
4235
4236         case KEY_dump:
4237             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4238             LOOPX(OP_DUMP);
4239
4240         case KEY_else:
4241             PREBLOCK(ELSE);
4242
4243         case KEY_elsif:
4244             yylval.ival = CopLINE(PL_curcop);
4245             OPERATOR(ELSIF);
4246
4247         case KEY_eq:
4248             Eop(OP_SEQ);
4249
4250         case KEY_exists:
4251             UNI(OP_EXISTS);
4252
4253         case KEY_exit:
4254             UNI(OP_EXIT);
4255
4256         case KEY_eval:
4257             s = skipspace(s);
4258             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4259             UNIBRACK(OP_ENTEREVAL);
4260
4261         case KEY_eof:
4262             UNI(OP_EOF);
4263
4264         case KEY_exp:
4265             UNI(OP_EXP);
4266
4267         case KEY_each:
4268             UNI(OP_EACH);
4269
4270         case KEY_exec:
4271             set_csh();
4272             LOP(OP_EXEC,XREF);
4273
4274         case KEY_endhostent:
4275             FUN0(OP_EHOSTENT);
4276
4277         case KEY_endnetent:
4278             FUN0(OP_ENETENT);
4279
4280         case KEY_endservent:
4281             FUN0(OP_ESERVENT);
4282
4283         case KEY_endprotoent:
4284             FUN0(OP_EPROTOENT);
4285
4286         case KEY_endpwent:
4287             FUN0(OP_EPWENT);
4288
4289         case KEY_endgrent:
4290             FUN0(OP_EGRENT);
4291
4292         case KEY_for:
4293         case KEY_foreach:
4294             yylval.ival = CopLINE(PL_curcop);
4295             s = skipspace(s);
4296             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4297                 char *p = s;
4298                 if ((PL_bufend - p) >= 3 &&
4299                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4300                     p += 2;
4301                 else if ((PL_bufend - p) >= 4 &&
4302                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4303                     p += 3;
4304                 p = skipspace(p);
4305                 if (isIDFIRST_lazy_if(p,UTF)) {
4306                     p = scan_ident(p, PL_bufend,
4307                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4308                     p = skipspace(p);
4309                 }
4310                 if (*p != '$')
4311                     Perl_croak(aTHX_ "Missing $ on loop variable");
4312             }
4313             OPERATOR(FOR);
4314
4315         case KEY_formline:
4316             LOP(OP_FORMLINE,XTERM);
4317
4318         case KEY_fork:
4319             FUN0(OP_FORK);
4320
4321         case KEY_fcntl:
4322             LOP(OP_FCNTL,XTERM);
4323
4324         case KEY_fileno:
4325             UNI(OP_FILENO);
4326
4327         case KEY_flock:
4328             LOP(OP_FLOCK,XTERM);
4329
4330         case KEY_gt:
4331             Rop(OP_SGT);
4332
4333         case KEY_ge:
4334             Rop(OP_SGE);
4335
4336         case KEY_grep:
4337             LOP(OP_GREPSTART, XREF);
4338
4339         case KEY_goto:
4340             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4341             LOOPX(OP_GOTO);
4342
4343         case KEY_gmtime:
4344             UNI(OP_GMTIME);
4345
4346         case KEY_getc:
4347             UNI(OP_GETC);
4348
4349         case KEY_getppid:
4350             FUN0(OP_GETPPID);
4351
4352         case KEY_getpgrp:
4353             UNI(OP_GETPGRP);
4354
4355         case KEY_getpriority:
4356             LOP(OP_GETPRIORITY,XTERM);
4357
4358         case KEY_getprotobyname:
4359             UNI(OP_GPBYNAME);
4360
4361         case KEY_getprotobynumber:
4362             LOP(OP_GPBYNUMBER,XTERM);
4363
4364         case KEY_getprotoent:
4365             FUN0(OP_GPROTOENT);
4366
4367         case KEY_getpwent:
4368             FUN0(OP_GPWENT);
4369
4370         case KEY_getpwnam:
4371             UNI(OP_GPWNAM);
4372
4373         case KEY_getpwuid:
4374             UNI(OP_GPWUID);
4375
4376         case KEY_getpeername:
4377             UNI(OP_GETPEERNAME);
4378
4379         case KEY_gethostbyname:
4380             UNI(OP_GHBYNAME);
4381
4382         case KEY_gethostbyaddr:
4383             LOP(OP_GHBYADDR,XTERM);
4384
4385         case KEY_gethostent:
4386             FUN0(OP_GHOSTENT);
4387
4388         case KEY_getnetbyname:
4389             UNI(OP_GNBYNAME);
4390
4391         case KEY_getnetbyaddr:
4392             LOP(OP_GNBYADDR,XTERM);
4393
4394         case KEY_getnetent:
4395             FUN0(OP_GNETENT);
4396
4397         case KEY_getservbyname:
4398             LOP(OP_GSBYNAME,XTERM);
4399
4400         case KEY_getservbyport:
4401             LOP(OP_GSBYPORT,XTERM);
4402
4403         case KEY_getservent:
4404             FUN0(OP_GSERVENT);
4405
4406         case KEY_getsockname:
4407             UNI(OP_GETSOCKNAME);
4408
4409         case KEY_getsockopt:
4410             LOP(OP_GSOCKOPT,XTERM);
4411
4412         case KEY_getgrent:
4413             FUN0(OP_GGRENT);
4414
4415         case KEY_getgrnam:
4416             UNI(OP_GGRNAM);
4417
4418         case KEY_getgrgid:
4419             UNI(OP_GGRGID);
4420
4421         case KEY_getlogin:
4422             FUN0(OP_GETLOGIN);
4423
4424         case KEY_glob:
4425             set_csh();
4426             LOP(OP_GLOB,XTERM);
4427
4428         case KEY_hex:
4429             UNI(OP_HEX);
4430
4431         case KEY_if:
4432             yylval.ival = CopLINE(PL_curcop);
4433             OPERATOR(IF);
4434
4435         case KEY_index:
4436             LOP(OP_INDEX,XTERM);
4437
4438         case KEY_int:
4439             UNI(OP_INT);
4440
4441         case KEY_ioctl:
4442             LOP(OP_IOCTL,XTERM);
4443
4444         case KEY_join:
4445             LOP(OP_JOIN,XTERM);
4446
4447         case KEY_keys:
4448             UNI(OP_KEYS);
4449
4450         case KEY_kill:
4451             LOP(OP_KILL,XTERM);
4452
4453         case KEY_last:
4454             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4455             LOOPX(OP_LAST);
4456
4457         case KEY_lc:
4458             UNI(OP_LC);
4459
4460         case KEY_lcfirst:
4461             UNI(OP_LCFIRST);
4462
4463         case KEY_local:
4464             yylval.ival = 0;
4465             OPERATOR(LOCAL);
4466
4467         case KEY_length:
4468             UNI(OP_LENGTH);
4469
4470         case KEY_lt:
4471             Rop(OP_SLT);
4472
4473         case KEY_le:
4474             Rop(OP_SLE);
4475
4476         case KEY_localtime:
4477             UNI(OP_LOCALTIME);
4478
4479         case KEY_log:
4480             UNI(OP_LOG);
4481
4482         case KEY_link:
4483             LOP(OP_LINK,XTERM);
4484
4485         case KEY_listen:
4486             LOP(OP_LISTEN,XTERM);
4487
4488         case KEY_lock:
4489             UNI(OP_LOCK);
4490
4491         case KEY_lstat:
4492             UNI(OP_LSTAT);
4493
4494         case KEY_m:
4495             s = scan_pat(s,OP_MATCH);
4496             TERM(sublex_start());
4497
4498         case KEY_map:
4499             LOP(OP_MAPSTART, XREF);
4500
4501         case KEY_mkdir:
4502             LOP(OP_MKDIR,XTERM);
4503
4504         case KEY_msgctl:
4505             LOP(OP_MSGCTL,XTERM);
4506
4507         case KEY_msgget:
4508             LOP(OP_MSGGET,XTERM);
4509
4510         case KEY_msgrcv:
4511             LOP(OP_MSGRCV,XTERM);
4512
4513         case KEY_msgsnd:
4514             LOP(OP_MSGSND,XTERM);
4515
4516         case KEY_our:
4517         case KEY_my:
4518             PL_in_my = tmp;
4519             s = skipspace(s);
4520             if (isIDFIRST_lazy_if(s,UTF)) {
4521                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4522                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4523                     goto really_sub;
4524                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4525                 if (!PL_in_my_stash) {
4526                     char tmpbuf[1024];
4527                     PL_bufptr = s;
4528                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4529                     yyerror(tmpbuf);
4530                 }
4531             }
4532             yylval.ival = 1;
4533             OPERATOR(MY);
4534
4535         case KEY_next:
4536             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4537             LOOPX(OP_NEXT);
4538
4539         case KEY_ne:
4540             Eop(OP_SNE);
4541
4542         case KEY_no:
4543             if (PL_expect != XSTATE)
4544                 yyerror("\"no\" not allowed in expression");
4545             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4546             s = force_version(s, FALSE);
4547             yylval.ival = 0;
4548             OPERATOR(USE);
4549
4550         case KEY_not:
4551             if (*s == '(' || (s = skipspace(s), *s == '('))
4552                 FUN1(OP_NOT);
4553             else
4554                 OPERATOR(NOTOP);
4555
4556         case KEY_open:
4557             s = skipspace(s);
4558             if (isIDFIRST_lazy_if(s,UTF)) {
4559                 char *t;
4560                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4561                 t = skipspace(d);
4562                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4563                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4564                            "Precedence problem: open %.*s should be open(%.*s)",
4565                             d-s,s, d-s,s);
4566             }
4567             LOP(OP_OPEN,XTERM);
4568
4569         case KEY_or:
4570             yylval.ival = OP_OR;
4571             OPERATOR(OROP);
4572
4573         case KEY_ord:
4574             UNI(OP_ORD);
4575
4576         case KEY_oct:
4577             UNI(OP_OCT);
4578
4579         case KEY_opendir:
4580             LOP(OP_OPEN_DIR,XTERM);
4581
4582         case KEY_print:
4583             checkcomma(s,PL_tokenbuf,"filehandle");
4584             LOP(OP_PRINT,XREF);
4585
4586         case KEY_printf:
4587             checkcomma(s,PL_tokenbuf,"filehandle");
4588             LOP(OP_PRTF,XREF);
4589
4590         case KEY_prototype:
4591             UNI(OP_PROTOTYPE);
4592
4593         case KEY_push:
4594             LOP(OP_PUSH,XTERM);
4595
4596         case KEY_pop:
4597             UNI(OP_POP);
4598
4599         case KEY_pos:
4600             UNI(OP_POS);
4601
4602         case KEY_pack:
4603             LOP(OP_PACK,XTERM);
4604
4605         case KEY_package:
4606             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4607             OPERATOR(PACKAGE);
4608
4609         case KEY_pipe:
4610             LOP(OP_PIPE_OP,XTERM);
4611
4612         case KEY_q:
4613             s = scan_str(s,FALSE,FALSE);
4614             if (!s)
4615                 missingterm((char*)0);
4616             yylval.ival = OP_CONST;
4617             TERM(sublex_start());
4618
4619         case KEY_quotemeta:
4620             UNI(OP_QUOTEMETA);
4621
4622         case KEY_qw:
4623             s = scan_str(s,FALSE,FALSE);
4624             if (!s)
4625                 missingterm((char*)0);
4626             force_next(')');
4627             if (SvCUR(PL_lex_stuff)) {
4628                 OP *words = Nullop;
4629                 int warned = 0;
4630                 d = SvPV_force(PL_lex_stuff, len);
4631                 while (len) {
4632                     SV *sv;
4633                     for (; isSPACE(*d) && len; --len, ++d) ;
4634                     if (len) {
4635                         char *b = d;
4636                         if (!warned && ckWARN(WARN_QW)) {
4637                             for (; !isSPACE(*d) && len; --len, ++d) {
4638                                 if (*d == ',') {
4639                                     Perl_warner(aTHX_ WARN_QW,
4640                                         "Possible attempt to separate words with commas");
4641                                     ++warned;
4642                                 }
4643                                 else if (*d == '#') {
4644                                     Perl_warner(aTHX_ WARN_QW,
4645                                         "Possible attempt to put comments in qw() list");
4646                                     ++warned;
4647                                 }
4648                             }
4649                         }
4650                         else {
4651                             for (; !isSPACE(*d) && len; --len, ++d) ;
4652                         }
4653                         sv = newSVpvn(b, d-b);
4654                         if (DO_UTF8(PL_lex_stuff))
4655                             SvUTF8_on(sv);
4656                         words = append_elem(OP_LIST, words,
4657                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4658                     }
4659                 }
4660                 if (words) {
4661                     PL_nextval[PL_nexttoke].opval = words;
4662                     force_next(THING);
4663                 }
4664             }
4665             if (PL_lex_stuff) {
4666                 SvREFCNT_dec(PL_lex_stuff);
4667                 PL_lex_stuff = Nullsv;
4668             }
4669             PL_expect = XTERM;
4670             TOKEN('(');
4671
4672         case KEY_qq:
4673             s = scan_str(s,FALSE,FALSE);
4674             if (!s)
4675                 missingterm((char*)0);
4676             yylval.ival = OP_STRINGIFY;
4677             if (SvIVX(PL_lex_stuff) == '\'')
4678                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4679             TERM(sublex_start());
4680
4681         case KEY_qr:
4682             s = scan_pat(s,OP_QR);
4683             TERM(sublex_start());
4684
4685         case KEY_qx:
4686             s = scan_str(s,FALSE,FALSE);
4687             if (!s)
4688                 missingterm((char*)0);
4689             yylval.ival = OP_BACKTICK;
4690             set_csh();
4691             TERM(sublex_start());
4692
4693         case KEY_return:
4694             OLDLOP(OP_RETURN);
4695
4696         case KEY_require:
4697             s = skipspace(s);
4698             if (isDIGIT(*s)) {
4699                 s = force_version(s, FALSE);
4700             }
4701             else if (*s != 'v' || !isDIGIT(s[1])
4702                     || (s = force_version(s, TRUE), *s == 'v'))
4703             {
4704                 *PL_tokenbuf = '\0';
4705                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4706                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4707                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4708                 else if (*s == '<')
4709                     yyerror("<> should be quotes");
4710             }
4711             UNI(OP_REQUIRE);
4712
4713         case KEY_reset:
4714             UNI(OP_RESET);
4715
4716         case KEY_redo:
4717             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4718             LOOPX(OP_REDO);
4719
4720         case KEY_rename:
4721             LOP(OP_RENAME,XTERM);
4722
4723         case KEY_rand:
4724             UNI(OP_RAND);
4725
4726         case KEY_rmdir:
4727             UNI(OP_RMDIR);
4728
4729         case KEY_rindex:
4730             LOP(OP_RINDEX,XTERM);
4731
4732         case KEY_read:
4733             LOP(OP_READ,XTERM);
4734
4735         case KEY_readdir:
4736             UNI(OP_READDIR);
4737
4738         case KEY_readline:
4739             set_csh();
4740             UNI(OP_READLINE);
4741
4742         case KEY_readpipe:
4743             set_csh();
4744             UNI(OP_BACKTICK);
4745
4746         case KEY_rewinddir:
4747             UNI(OP_REWINDDIR);
4748
4749         case KEY_recv:
4750             LOP(OP_RECV,XTERM);
4751
4752         case KEY_reverse:
4753             LOP(OP_REVERSE,XTERM);
4754
4755         case KEY_readlink:
4756             UNI(OP_READLINK);
4757
4758         case KEY_ref:
4759             UNI(OP_REF);
4760
4761         case KEY_s:
4762             s = scan_subst(s);
4763             if (yylval.opval)
4764                 TERM(sublex_start());
4765             else
4766                 TOKEN(1);       /* force error */
4767
4768         case KEY_chomp:
4769             UNI(OP_CHOMP);
4770
4771         case KEY_scalar:
4772             UNI(OP_SCALAR);
4773
4774         case KEY_select:
4775             LOP(OP_SELECT,XTERM);
4776
4777         case KEY_seek:
4778             LOP(OP_SEEK,XTERM);
4779
4780         case KEY_semctl:
4781             LOP(OP_SEMCTL,XTERM);
4782
4783         case KEY_semget:
4784             LOP(OP_SEMGET,XTERM);
4785
4786         case KEY_semop:
4787             LOP(OP_SEMOP,XTERM);
4788
4789         case KEY_send:
4790             LOP(OP_SEND,XTERM);
4791
4792         case KEY_setpgrp:
4793             LOP(OP_SETPGRP,XTERM);
4794
4795         case KEY_setpriority:
4796             LOP(OP_SETPRIORITY,XTERM);
4797
4798         case KEY_sethostent:
4799             UNI(OP_SHOSTENT);
4800
4801         case KEY_setnetent:
4802             UNI(OP_SNETENT);
4803
4804         case KEY_setservent:
4805             UNI(OP_SSERVENT);
4806
4807         case KEY_setprotoent:
4808             UNI(OP_SPROTOENT);
4809
4810         case KEY_setpwent:
4811             FUN0(OP_SPWENT);
4812
4813         case KEY_setgrent:
4814             FUN0(OP_SGRENT);
4815
4816         case KEY_seekdir:
4817             LOP(OP_SEEKDIR,XTERM);
4818
4819         case KEY_setsockopt:
4820             LOP(OP_SSOCKOPT,XTERM);
4821
4822         case KEY_shift:
4823             UNI(OP_SHIFT);
4824
4825         case KEY_shmctl:
4826             LOP(OP_SHMCTL,XTERM);
4827
4828         case KEY_shmget:
4829             LOP(OP_SHMGET,XTERM);
4830
4831         case KEY_shmread:
4832             LOP(OP_SHMREAD,XTERM);
4833
4834         case KEY_shmwrite:
4835             LOP(OP_SHMWRITE,XTERM);
4836
4837         case KEY_shutdown:
4838             LOP(OP_SHUTDOWN,XTERM);
4839
4840         case KEY_sin:
4841             UNI(OP_SIN);
4842
4843         case KEY_sleep:
4844             UNI(OP_SLEEP);
4845
4846         case KEY_socket:
4847             LOP(OP_SOCKET,XTERM);
4848
4849         case KEY_socketpair:
4850             LOP(OP_SOCKPAIR,XTERM);
4851
4852         case KEY_sort:
4853             checkcomma(s,PL_tokenbuf,"subroutine name");
4854             s = skipspace(s);
4855             if (*s == ';' || *s == ')')         /* probably a close */
4856                 Perl_croak(aTHX_ "sort is now a reserved word");
4857             PL_expect = XTERM;
4858             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4859             LOP(OP_SORT,XREF);
4860
4861         case KEY_split:
4862             LOP(OP_SPLIT,XTERM);
4863
4864         case KEY_sprintf:
4865             LOP(OP_SPRINTF,XTERM);
4866
4867         case KEY_splice:
4868             LOP(OP_SPLICE,XTERM);
4869
4870         case KEY_sqrt:
4871             UNI(OP_SQRT);
4872
4873         case KEY_srand:
4874             UNI(OP_SRAND);
4875
4876         case KEY_stat:
4877             UNI(OP_STAT);
4878
4879         case KEY_study:
4880             UNI(OP_STUDY);
4881
4882         case KEY_substr:
4883             LOP(OP_SUBSTR,XTERM);
4884
4885         case KEY_format:
4886         case KEY_sub:
4887           really_sub:
4888             {
4889                 char tmpbuf[sizeof PL_tokenbuf];
4890                 SSize_t tboffset = 0;
4891                 expectation attrful;
4892                 bool have_name, have_proto;
4893                 int key = tmp;
4894
4895                 s = skipspace(s);
4896
4897                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4898                     (*s == ':' && s[1] == ':'))
4899                 {
4900                     PL_expect = XBLOCK;
4901                     attrful = XATTRBLOCK;
4902                     /* remember buffer pos'n for later force_word */
4903                     tboffset = s - PL_oldbufptr;
4904                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4905                     if (strchr(tmpbuf, ':'))
4906                         sv_setpv(PL_subname, tmpbuf);
4907                     else {
4908                         sv_setsv(PL_subname,PL_curstname);
4909                         sv_catpvn(PL_subname,"::",2);
4910                         sv_catpvn(PL_subname,tmpbuf,len);
4911                     }
4912                     s = skipspace(d);
4913                     have_name = TRUE;
4914                 }
4915                 else {
4916                     if (key == KEY_my)
4917                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4918                     PL_expect = XTERMBLOCK;
4919                     attrful = XATTRTERM;
4920                     sv_setpv(PL_subname,"?");
4921                     have_name = FALSE;
4922                 }
4923
4924                 if (key == KEY_format) {
4925                     if (*s == '=')
4926                         PL_lex_formbrack = PL_lex_brackets + 1;
4927                     if (have_name)
4928                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4929                                           FALSE, TRUE, TRUE);
4930                     OPERATOR(FORMAT);
4931                 }
4932
4933                 /* Look for a prototype */
4934                 if (*s == '(') {
4935                     char *p;
4936
4937                     s = scan_str(s,FALSE,FALSE);
4938                     if (!s)
4939                         Perl_croak(aTHX_ "Prototype not terminated");
4940                     /* strip spaces */
4941                     d = SvPVX(PL_lex_stuff);
4942                     tmp = 0;
4943                     for (p = d; *p; ++p) {
4944                         if (!isSPACE(*p))
4945                             d[tmp++] = *p;
4946                     }
4947                     d[tmp] = '\0';
4948                     SvCUR(PL_lex_stuff) = tmp;
4949                     have_proto = TRUE;
4950
4951                     s = skipspace(s);
4952                 }
4953                 else
4954                     have_proto = FALSE;
4955
4956                 if (*s == ':' && s[1] != ':')
4957                     PL_expect = attrful;
4958
4959                 if (have_proto) {
4960                     PL_nextval[PL_nexttoke].opval =
4961                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4962                     PL_lex_stuff = Nullsv;
4963                     force_next(THING);
4964                 }
4965                 if (!have_name) {
4966                     sv_setpv(PL_subname,"__ANON__");
4967                     TOKEN(ANONSUB);
4968                 }
4969                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4970                                   FALSE, TRUE, TRUE);
4971                 if (key == KEY_my)
4972                     TOKEN(MYSUB);
4973                 TOKEN(SUB);
4974             }
4975
4976         case KEY_system:
4977             set_csh();
4978             LOP(OP_SYSTEM,XREF);
4979
4980         case KEY_symlink:
4981             LOP(OP_SYMLINK,XTERM);
4982
4983         case KEY_syscall:
4984             LOP(OP_SYSCALL,XTERM);
4985
4986         case KEY_sysopen:
4987             LOP(OP_SYSOPEN,XTERM);
4988
4989         case KEY_sysseek:
4990             LOP(OP_SYSSEEK,XTERM);
4991
4992         case KEY_sysread:
4993             LOP(OP_SYSREAD,XTERM);
4994
4995         case KEY_syswrite:
4996             LOP(OP_SYSWRITE,XTERM);
4997
4998         case KEY_tr:
4999             s = scan_trans(s);
5000             TERM(sublex_start());
5001
5002         case KEY_tell:
5003             UNI(OP_TELL);
5004
5005         case KEY_telldir:
5006             UNI(OP_TELLDIR);
5007
5008         case KEY_tie:
5009             LOP(OP_TIE,XTERM);
5010
5011         case KEY_tied:
5012             UNI(OP_TIED);
5013
5014         case KEY_time:
5015             FUN0(OP_TIME);
5016
5017         case KEY_times:
5018             FUN0(OP_TMS);
5019
5020         case KEY_truncate:
5021             LOP(OP_TRUNCATE,XTERM);
5022
5023         case KEY_uc:
5024             UNI(OP_UC);
5025
5026         case KEY_ucfirst:
5027             UNI(OP_UCFIRST);
5028
5029         case KEY_untie:
5030             UNI(OP_UNTIE);
5031
5032         case KEY_until:
5033             yylval.ival = CopLINE(PL_curcop);
5034             OPERATOR(UNTIL);
5035
5036         case KEY_unless:
5037             yylval.ival = CopLINE(PL_curcop);
5038             OPERATOR(UNLESS);
5039
5040         case KEY_unlink:
5041             LOP(OP_UNLINK,XTERM);
5042
5043         case KEY_undef:
5044             UNI(OP_UNDEF);
5045
5046         case KEY_unpack:
5047             LOP(OP_UNPACK,XTERM);
5048
5049         case KEY_utime:
5050             LOP(OP_UTIME,XTERM);
5051
5052         case KEY_umask:
5053             UNI(OP_UMASK);
5054
5055         case KEY_unshift:
5056             LOP(OP_UNSHIFT,XTERM);
5057
5058         case KEY_use:
5059             if (PL_expect != XSTATE)
5060                 yyerror("\"use\" not allowed in expression");
5061             s = skipspace(s);
5062             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5063                 s = force_version(s, TRUE);
5064                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5065                     PL_nextval[PL_nexttoke].opval = Nullop;
5066                     force_next(WORD);
5067                 }
5068                 else if (*s == 'v') {
5069                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5070                     s = force_version(s, FALSE);
5071                 }
5072             }
5073             else {
5074                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5075                 s = force_version(s, FALSE);
5076             }
5077             yylval.ival = 1;
5078             OPERATOR(USE);
5079
5080         case KEY_values:
5081             UNI(OP_VALUES);
5082
5083         case KEY_vec:
5084             LOP(OP_VEC,XTERM);
5085
5086         case KEY_while:
5087             yylval.ival = CopLINE(PL_curcop);
5088             OPERATOR(WHILE);
5089
5090         case KEY_warn:
5091             PL_hints |= HINT_BLOCK_SCOPE;
5092             LOP(OP_WARN,XTERM);
5093
5094         case KEY_wait:
5095             FUN0(OP_WAIT);
5096
5097         case KEY_waitpid:
5098             LOP(OP_WAITPID,XTERM);
5099
5100         case KEY_wantarray:
5101             FUN0(OP_WANTARRAY);
5102
5103         case KEY_write:
5104 #ifdef EBCDIC
5105         {
5106             char ctl_l[2];
5107             ctl_l[0] = toCTRL('L');
5108             ctl_l[1] = '\0';
5109             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5110         }
5111 #else
5112             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5113 #endif
5114             UNI(OP_ENTERWRITE);
5115
5116         case KEY_x:
5117             if (PL_expect == XOPERATOR)
5118                 Mop(OP_REPEAT);
5119             check_uni();
5120             goto just_a_word;
5121
5122         case KEY_xor:
5123             yylval.ival = OP_XOR;
5124             OPERATOR(OROP);
5125
5126         case KEY_y:
5127             s = scan_trans(s);
5128             TERM(sublex_start());
5129         }
5130     }}
5131 }
5132 #ifdef __SC__
5133 #pragma segment Main
5134 #endif
5135
5136 static int
5137 S_pending_ident(pTHX)
5138 {
5139     register char *d;
5140     register I32 tmp;
5141     /* pit holds the identifier we read and pending_ident is reset */
5142     char pit = PL_pending_ident;
5143     PL_pending_ident = 0;
5144
5145     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5146           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5147
5148     /* if we're in a my(), we can't allow dynamics here.
5149        $foo'bar has already been turned into $foo::bar, so
5150        just check for colons.
5151
5152        if it's a legal name, the OP is a PADANY.
5153     */
5154     if (PL_in_my) {
5155         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5156             if (strchr(PL_tokenbuf,':'))
5157                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5158                                   "variable %s in \"our\"",
5159                                   PL_tokenbuf));
5160             tmp = pad_allocmy(PL_tokenbuf);
5161         }
5162         else {
5163             if (strchr(PL_tokenbuf,':'))
5164                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5165
5166             yylval.opval = newOP(OP_PADANY, 0);
5167             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5168             return PRIVATEREF;
5169         }
5170     }
5171
5172     /*
5173        build the ops for accesses to a my() variable.
5174
5175        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5176        then used in a comparison.  This catches most, but not
5177        all cases.  For instance, it catches
5178            sort { my($a); $a <=> $b }
5179        but not
5180            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5181        (although why you'd do that is anyone's guess).
5182     */
5183
5184     if (!strchr(PL_tokenbuf,':')) {
5185 #ifdef USE_5005THREADS
5186         /* Check for single character per-thread SVs */
5187         if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5188             && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5189             && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5190         {
5191             yylval.opval = newOP(OP_THREADSV, 0);
5192             yylval.opval->op_targ = tmp;
5193             return PRIVATEREF;
5194         }
5195 #endif /* USE_5005THREADS */
5196         if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5197             SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5198             /* might be an "our" variable" */
5199             if (SvFLAGS(namesv) & SVpad_OUR) {
5200                 /* build ops for a bareword */
5201                 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5202                 sv_catpvn(sym, "::", 2);
5203                 sv_catpv(sym, PL_tokenbuf+1);
5204                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5205                 yylval.opval->op_private = OPpCONST_ENTERED;
5206                 gv_fetchpv(SvPVX(sym),
5207                     (PL_in_eval
5208                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5209                         : TRUE
5210                     ),
5211                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5212                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5213                      : SVt_PVHV));
5214                 return WORD;
5215             }
5216
5217             /* if it's a sort block and they're naming $a or $b */
5218             if (PL_last_lop_op == OP_SORT &&
5219                 PL_tokenbuf[0] == '$' &&
5220                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5221                 && !PL_tokenbuf[2])
5222             {
5223                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5224                      d < PL_bufend && *d != '\n';
5225                      d++)
5226                 {
5227                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5228                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5229                               PL_tokenbuf);
5230                     }
5231                 }
5232             }
5233
5234             yylval.opval = newOP(OP_PADANY, 0);
5235             yylval.opval->op_targ = tmp;
5236             return PRIVATEREF;
5237         }
5238     }
5239
5240     /*
5241        Whine if they've said @foo in a doublequoted string,
5242        and @foo isn't a variable we can find in the symbol
5243        table.
5244     */
5245     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5246         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5247         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5248              && ckWARN(WARN_AMBIGUOUS))
5249         {
5250             /* Downgraded from fatal to warning 20000522 mjd */
5251             Perl_warner(aTHX_ WARN_AMBIGUOUS,
5252                         "Possible unintended interpolation of %s in string",
5253                          PL_tokenbuf);
5254         }
5255     }
5256
5257     /* build ops for a bareword */
5258     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5259     yylval.opval->op_private = OPpCONST_ENTERED;
5260     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5261                ((PL_tokenbuf[0] == '$') ? SVt_PV
5262                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5263                 : SVt_PVHV));
5264     return WORD;
5265 }
5266
5267 I32
5268 Perl_keyword(pTHX_ register char *d, I32 len)
5269 {
5270     switch (*d) {
5271     case '_':
5272         if (d[1] == '_') {
5273             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5274             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5275             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5276             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5277             if (strEQ(d,"__END__"))             return KEY___END__;
5278         }
5279         break;
5280     case 'A':
5281         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5282         break;
5283     case 'a':
5284         switch (len) {
5285         case 3:
5286             if (strEQ(d,"and"))                 return -KEY_and;
5287             if (strEQ(d,"abs"))                 return -KEY_abs;
5288             break;
5289         case 5:
5290             if (strEQ(d,"alarm"))               return -KEY_alarm;
5291             if (strEQ(d,"atan2"))               return -KEY_atan2;
5292             break;
5293         case 6:
5294             if (strEQ(d,"accept"))              return -KEY_accept;
5295             break;
5296         }
5297         break;
5298     case 'B':
5299         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5300         break;
5301     case 'b':
5302         if (strEQ(d,"bless"))                   return -KEY_bless;
5303         if (strEQ(d,"bind"))                    return -KEY_bind;
5304         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5305         break;
5306     case 'C':
5307         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5308         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5309         break;
5310     case 'c':
5311         switch (len) {
5312         case 3:
5313             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5314             if (strEQ(d,"chr"))                 return -KEY_chr;
5315             if (strEQ(d,"cos"))                 return -KEY_cos;
5316             break;
5317         case 4:
5318             if (strEQ(d,"chop"))                return -KEY_chop;
5319             break;
5320         case 5:
5321             if (strEQ(d,"close"))               return -KEY_close;
5322             if (strEQ(d,"chdir"))               return -KEY_chdir;
5323             if (strEQ(d,"chomp"))               return -KEY_chomp;
5324             if (strEQ(d,"chmod"))               return -KEY_chmod;
5325             if (strEQ(d,"chown"))               return -KEY_chown;
5326             if (strEQ(d,"crypt"))               return -KEY_crypt;
5327             break;
5328         case 6:
5329             if (strEQ(d,"chroot"))              return -KEY_chroot;
5330             if (strEQ(d,"caller"))              return -KEY_caller;
5331             break;
5332         case 7:
5333             if (strEQ(d,"connect"))             return -KEY_connect;
5334             break;
5335         case 8:
5336             if (strEQ(d,"closedir"))            return -KEY_closedir;
5337             if (strEQ(d,"continue"))            return -KEY_continue;
5338             break;
5339         }
5340         break;
5341     case 'D':
5342         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5343         break;
5344     case 'd':
5345         switch (len) {
5346         case 2:
5347             if (strEQ(d,"do"))                  return KEY_do;
5348             break;
5349         case 3:
5350             if (strEQ(d,"die"))                 return -KEY_die;
5351             break;
5352         case 4:
5353             if (strEQ(d,"dump"))                return -KEY_dump;
5354             break;
5355         case 6:
5356             if (strEQ(d,"delete"))              return KEY_delete;
5357             break;
5358         case 7:
5359             if (strEQ(d,"defined"))             return KEY_defined;
5360             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5361             break;
5362         case 8:
5363             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5364             break;
5365         }
5366         break;
5367     case 'E':
5368         if (strEQ(d,"END"))                     return KEY_END;
5369         break;
5370     case 'e':
5371         switch (len) {
5372         case 2:
5373             if (strEQ(d,"eq"))                  return -KEY_eq;
5374             break;
5375         case 3:
5376             if (strEQ(d,"eof"))                 return -KEY_eof;
5377             if (strEQ(d,"exp"))                 return -KEY_exp;
5378             break;
5379         case 4:
5380             if (strEQ(d,"else"))                return KEY_else;
5381             if (strEQ(d,"exit"))                return -KEY_exit;
5382             if (strEQ(d,"eval"))                return KEY_eval;
5383             if (strEQ(d,"exec"))                return -KEY_exec;
5384            if (strEQ(d,"each"))                return -KEY_each;
5385             break;
5386         case 5:
5387             if (strEQ(d,"elsif"))               return KEY_elsif;
5388             break;
5389         case 6:
5390             if (strEQ(d,"exists"))              return KEY_exists;
5391             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5392             break;
5393         case 8:
5394             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5395             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5396             break;
5397         case 9:
5398             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5399             break;
5400         case 10:
5401             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5402             if (strEQ(d,"endservent"))          return -KEY_endservent;
5403             break;
5404         case 11:
5405             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5406             break;
5407         }
5408         break;
5409     case 'f':
5410         switch (len) {
5411         case 3:
5412             if (strEQ(d,"for"))                 return KEY_for;
5413             break;
5414         case 4:
5415             if (strEQ(d,"fork"))                return -KEY_fork;
5416             break;
5417         case 5:
5418             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5419             if (strEQ(d,"flock"))               return -KEY_flock;
5420             break;
5421         case 6:
5422             if (strEQ(d,"format"))              return KEY_format;
5423             if (strEQ(d,"fileno"))              return -KEY_fileno;
5424             break;
5425         case 7:
5426             if (strEQ(d,"foreach"))             return KEY_foreach;
5427             break;
5428         case 8:
5429             if (strEQ(d,"formline"))            return -KEY_formline;
5430             break;
5431         }
5432         break;
5433     case 'g':
5434         if (strnEQ(d,"get",3)) {
5435             d += 3;
5436             if (*d == 'p') {
5437                 switch (len) {
5438                 case 7:
5439                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5440                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5441                     break;
5442                 case 8:
5443                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5444                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5445                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5446                     break;
5447                 case 11:
5448                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5449                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5450                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5451                     break;
5452                 case 14:
5453                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5454                     break;
5455                 case 16:
5456                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5457                     break;
5458                 }
5459             }
5460             else if (*d == 'h') {
5461                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5462                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5463                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5464             }
5465             else if (*d == 'n') {
5466                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5467                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5468                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5469             }
5470             else if (*d == 's') {
5471                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5472                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5473                 if (strEQ(d,"servent"))         return -KEY_getservent;
5474                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5475                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5476             }
5477             else if (*d == 'g') {
5478                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5479                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5480                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5481             }
5482             else if (*d == 'l') {
5483                 if (strEQ(d,"login"))           return -KEY_getlogin;
5484             }
5485             else if (strEQ(d,"c"))              return -KEY_getc;
5486             break;
5487         }
5488         switch (len) {
5489         case 2:
5490             if (strEQ(d,"gt"))                  return -KEY_gt;
5491             if (strEQ(d,"ge"))                  return -KEY_ge;
5492             break;
5493         case 4:
5494             if (strEQ(d,"grep"))                return KEY_grep;
5495             if (strEQ(d,"goto"))                return KEY_goto;
5496             if (strEQ(d,"glob"))                return KEY_glob;
5497             break;
5498         case 6:
5499             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5500             break;
5501         }
5502         break;
5503     case 'h':
5504         if (strEQ(d,"hex"))                     return -KEY_hex;
5505         break;
5506     case 'I':
5507         if (strEQ(d,"INIT"))                    return KEY_INIT;
5508         break;
5509     case 'i':
5510         switch (len) {
5511         case 2:
5512             if (strEQ(d,"if"))                  return KEY_if;
5513             break;
5514         case 3:
5515             if (strEQ(d,"int"))                 return -KEY_int;
5516             break;
5517         case 5:
5518             if (strEQ(d,"index"))               return -KEY_index;
5519             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5520             break;
5521         }
5522         break;
5523     case 'j':
5524         if (strEQ(d,"join"))                    return -KEY_join;
5525         break;
5526     case 'k':
5527         if (len == 4) {
5528            if (strEQ(d,"keys"))                return -KEY_keys;
5529             if (strEQ(d,"kill"))                return -KEY_kill;
5530         }
5531         break;
5532     case 'l':
5533         switch (len) {
5534         case 2:
5535             if (strEQ(d,"lt"))                  return -KEY_lt;
5536             if (strEQ(d,"le"))                  return -KEY_le;
5537             if (strEQ(d,"lc"))                  return -KEY_lc;
5538             break;
5539         case 3:
5540             if (strEQ(d,"log"))                 return -KEY_log;
5541             break;
5542         case 4:
5543             if (strEQ(d,"last"))                return KEY_last;
5544             if (strEQ(d,"link"))                return -KEY_link;
5545             if (strEQ(d,"lock"))                return -KEY_lock;
5546             break;
5547         case 5:
5548             if (strEQ(d,"local"))               return KEY_local;
5549             if (strEQ(d,"lstat"))               return -KEY_lstat;
5550             break;
5551         case 6:
5552             if (strEQ(d,"length"))              return -KEY_length;
5553             if (strEQ(d,"listen"))              return -KEY_listen;
5554             break;
5555         case 7:
5556             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5557             break;
5558         case 9:
5559             if (strEQ(d,"localtime"))           return -KEY_localtime;
5560             break;
5561         }
5562         break;
5563     case 'm':
5564         switch (len) {
5565         case 1:                                 return KEY_m;
5566         case 2:
5567             if (strEQ(d,"my"))                  return KEY_my;
5568             break;
5569         case 3:
5570             if (strEQ(d,"map"))                 return KEY_map;
5571             break;
5572         case 5:
5573             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5574             break;
5575         case 6:
5576             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5577             if (strEQ(d,"msgget"))              return -KEY_msgget;
5578             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5579             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5580             break;
5581         }
5582         break;
5583     case 'n':
5584         if (strEQ(d,"next"))                    return KEY_next;
5585         if (strEQ(d,"ne"))                      return -KEY_ne;
5586         if (strEQ(d,"not"))                     return -KEY_not;
5587         if (strEQ(d,"no"))                      return KEY_no;
5588         break;
5589     case 'o':
5590         switch (len) {
5591         case 2:
5592             if (strEQ(d,"or"))                  return -KEY_or;
5593             break;
5594         case 3:
5595             if (strEQ(d,"ord"))                 return -KEY_ord;
5596             if (strEQ(d,"oct"))                 return -KEY_oct;
5597             if (strEQ(d,"our"))                 return KEY_our;
5598             break;
5599         case 4:
5600             if (strEQ(d,"open"))                return -KEY_open;
5601             break;
5602         case 7:
5603             if (strEQ(d,"opendir"))             return -KEY_opendir;
5604             break;
5605         }
5606         break;
5607     case 'p':
5608         switch (len) {
5609         case 3:
5610            if (strEQ(d,"pop"))                 return -KEY_pop;
5611             if (strEQ(d,"pos"))                 return KEY_pos;
5612             break;
5613         case 4:
5614            if (strEQ(d,"push"))                return -KEY_push;
5615             if (strEQ(d,"pack"))                return -KEY_pack;
5616             if (strEQ(d,"pipe"))                return -KEY_pipe;
5617             break;
5618         case 5:
5619             if (strEQ(d,"print"))               return KEY_print;
5620             break;
5621         case 6:
5622             if (strEQ(d,"printf"))              return KEY_printf;
5623             break;
5624         case 7:
5625             if (strEQ(d,"package"))             return KEY_package;
5626             break;
5627         case 9:
5628             if (strEQ(d,"prototype"))           return KEY_prototype;
5629         }
5630         break;
5631     case 'q':
5632         if (len <= 2) {
5633             if (strEQ(d,"q"))                   return KEY_q;
5634             if (strEQ(d,"qr"))                  return KEY_qr;
5635             if (strEQ(d,"qq"))                  return KEY_qq;
5636             if (strEQ(d,"qw"))                  return KEY_qw;
5637             if (strEQ(d,"qx"))                  return KEY_qx;
5638         }
5639         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5640         break;
5641     case 'r':
5642         switch (len) {
5643         case 3:
5644             if (strEQ(d,"ref"))                 return -KEY_ref;
5645             break;
5646         case 4:
5647             if (strEQ(d,"read"))                return -KEY_read;
5648             if (strEQ(d,"rand"))                return -KEY_rand;
5649             if (strEQ(d,"recv"))                return -KEY_recv;
5650             if (strEQ(d,"redo"))                return KEY_redo;
5651             break;
5652         case 5:
5653             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5654             if (strEQ(d,"reset"))               return -KEY_reset;
5655             break;
5656         case 6:
5657             if (strEQ(d,"return"))              return KEY_return;
5658             if (strEQ(d,"rename"))              return -KEY_rename;
5659             if (strEQ(d,"rindex"))              return -KEY_rindex;
5660             break;
5661         case 7:
5662             if (strEQ(d,"require"))             return KEY_require;
5663             if (strEQ(d,"reverse"))             return -KEY_reverse;
5664             if (strEQ(d,"readdir"))             return -KEY_readdir;
5665             break;
5666         case 8:
5667             if (strEQ(d,"readlink"))            return -KEY_readlink;
5668             if (strEQ(d,"readline"))            return -KEY_readline;
5669             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5670             break;
5671         case 9:
5672             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5673             break;
5674         }
5675         break;
5676     case 's':
5677         switch (d[1]) {
5678         case 0:                                 return KEY_s;
5679         case 'c':
5680             if (strEQ(d,"scalar"))              return KEY_scalar;
5681             break;
5682         case 'e':
5683             switch (len) {
5684             case 4:
5685                 if (strEQ(d,"seek"))            return -KEY_seek;
5686                 if (strEQ(d,"send"))            return -KEY_send;
5687                 break;
5688             case 5:
5689                 if (strEQ(d,"semop"))           return -KEY_semop;
5690                 break;
5691             case 6:
5692                 if (strEQ(d,"select"))          return -KEY_select;
5693                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5694                 if (strEQ(d,"semget"))          return -KEY_semget;
5695                 break;
5696             case 7:
5697                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5698                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5699                 break;
5700             case 8:
5701                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5702                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5703                 break;
5704             case 9:
5705                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5706                 break;
5707             case 10:
5708                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5709                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5710                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5711                 break;
5712             case 11:
5713                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5714                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5715                 break;
5716             }
5717             break;
5718         case 'h':
5719             switch (len) {
5720             case 5:
5721                if (strEQ(d,"shift"))           return -KEY_shift;
5722                 break;
5723             case 6:
5724                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5725                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5726                 break;
5727             case 7:
5728                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5729                 break;
5730             case 8:
5731                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5732                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5733                 break;
5734             }
5735             break;
5736         case 'i':
5737             if (strEQ(d,"sin"))                 return -KEY_sin;
5738             break;
5739         case 'l':
5740             if (strEQ(d,"sleep"))               return -KEY_sleep;
5741             break;
5742         case 'o':
5743             if (strEQ(d,"sort"))                return KEY_sort;
5744             if (strEQ(d,"socket"))              return -KEY_socket;
5745             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5746             break;
5747         case 'p':
5748             if (strEQ(d,"split"))               return KEY_split;
5749             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5750            if (strEQ(d,"splice"))              return -KEY_splice;
5751             break;
5752         case 'q':
5753             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5754             break;
5755         case 'r':
5756             if (strEQ(d,"srand"))               return -KEY_srand;
5757             break;
5758         case 't':
5759             if (strEQ(d,"stat"))                return -KEY_stat;
5760             if (strEQ(d,"study"))               return KEY_study;
5761             break;
5762         case 'u':
5763             if (strEQ(d,"substr"))              return -KEY_substr;
5764             if (strEQ(d,"sub"))                 return KEY_sub;
5765             break;
5766         case 'y':
5767             switch (len) {
5768             case 6:
5769                 if (strEQ(d,"system"))          return -KEY_system;
5770                 break;
5771             case 7:
5772                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5773                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5774                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5775                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5776                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5777                 break;
5778             case 8:
5779                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5780                 break;
5781             }
5782             break;
5783         }
5784         break;
5785     case 't':
5786         switch (len) {
5787         case 2:
5788             if (strEQ(d,"tr"))                  return KEY_tr;
5789             break;
5790         case 3:
5791             if (strEQ(d,"tie"))                 return KEY_tie;
5792             break;
5793         case 4:
5794             if (strEQ(d,"tell"))                return -KEY_tell;
5795             if (strEQ(d,"tied"))                return KEY_tied;
5796             if (strEQ(d,"time"))                return -KEY_time;
5797             break;
5798         case 5:
5799             if (strEQ(d,"times"))               return -KEY_times;
5800             break;
5801         case 7:
5802             if (strEQ(d,"telldir"))             return -KEY_telldir;
5803             break;
5804         case 8:
5805             if (strEQ(d,"truncate"))            return -KEY_truncate;
5806             break;
5807         }
5808         break;
5809     case 'u':
5810         switch (len) {
5811         case 2:
5812             if (strEQ(d,"uc"))                  return -KEY_uc;
5813             break;
5814         case 3:
5815             if (strEQ(d,"use"))                 return KEY_use;
5816             break;
5817         case 5:
5818             if (strEQ(d,"undef"))               return KEY_undef;
5819             if (strEQ(d,"until"))               return KEY_until;
5820             if (strEQ(d,"untie"))               return KEY_untie;
5821             if (strEQ(d,"utime"))               return -KEY_utime;
5822             if (strEQ(d,"umask"))               return -KEY_umask;
5823             break;
5824         case 6:
5825             if (strEQ(d,"unless"))              return KEY_unless;
5826             if (strEQ(d,"unpack"))              return -KEY_unpack;
5827             if (strEQ(d,"unlink"))              return -KEY_unlink;
5828             break;
5829         case 7:
5830            if (strEQ(d,"unshift"))             return -KEY_unshift;
5831             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5832             break;
5833         }
5834         break;
5835     case 'v':
5836         if (strEQ(d,"values"))                  return -KEY_values;
5837         if (strEQ(d,"vec"))                     return -KEY_vec;
5838         break;
5839     case 'w':
5840         switch (len) {
5841         case 4:
5842             if (strEQ(d,"warn"))                return -KEY_warn;
5843             if (strEQ(d,"wait"))                return -KEY_wait;
5844             break;
5845         case 5:
5846             if (strEQ(d,"while"))               return KEY_while;
5847             if (strEQ(d,"write"))               return -KEY_write;
5848             break;
5849         case 7:
5850             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5851             break;
5852         case 9:
5853             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5854             break;
5855         }
5856         break;
5857     case 'x':
5858         if (len == 1)                           return -KEY_x;
5859         if (strEQ(d,"xor"))                     return -KEY_xor;
5860         break;
5861     case 'y':
5862         if (len == 1)                           return KEY_y;
5863         break;
5864     case 'z':
5865         break;
5866     }
5867     return 0;
5868 }
5869
5870 STATIC void
5871 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5872 {
5873     char *w;
5874
5875     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5876         if (ckWARN(WARN_SYNTAX)) {
5877             int level = 1;
5878             for (w = s+2; *w && level; w++) {
5879                 if (*w == '(')
5880                     ++level;
5881                 else if (*w == ')')
5882                     --level;
5883             }
5884             if (*w)
5885                 for (; *w && isSPACE(*w); w++) ;
5886             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5887                 Perl_warner(aTHX_ WARN_SYNTAX,
5888                             "%s (...) interpreted as function",name);
5889         }
5890     }
5891     while (s < PL_bufend && isSPACE(*s))
5892         s++;
5893     if (*s == '(')
5894         s++;
5895     while (s < PL_bufend && isSPACE(*s))
5896         s++;
5897     if (isIDFIRST_lazy_if(s,UTF)) {
5898         w = s++;
5899         while (isALNUM_lazy_if(s,UTF))
5900             s++;
5901         while (s < PL_bufend && isSPACE(*s))
5902             s++;
5903         if (*s == ',') {
5904             int kw;
5905             *s = '\0';
5906             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5907             *s = ',';
5908             if (kw)
5909                 return;
5910             Perl_croak(aTHX_ "No comma allowed after %s", what);
5911         }
5912     }
5913 }
5914
5915 /* Either returns sv, or mortalizes sv and returns a new SV*.
5916    Best used as sv=new_constant(..., sv, ...).
5917    If s, pv are NULL, calls subroutine with one argument,
5918    and type is used with error messages only. */
5919
5920 STATIC SV *
5921 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5922                const char *type)
5923 {
5924     dSP;
5925     HV *table = GvHV(PL_hintgv);                 /* ^H */
5926     SV *res;
5927     SV **cvp;
5928     SV *cv, *typesv;
5929     const char *why1, *why2, *why3;
5930
5931     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5932         SV *msg;
5933
5934         why2 = strEQ(key,"charnames")
5935                ? "(possibly a missing \"use charnames ...\")"
5936                : "";
5937         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5938                             (type ? type: "undef"), why2);
5939
5940         /* This is convoluted and evil ("goto considered harmful")
5941          * but I do not understand the intricacies of all the different
5942          * failure modes of %^H in here.  The goal here is to make
5943          * the most probable error message user-friendly. --jhi */
5944
5945         goto msgdone;
5946
5947     report:
5948         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5949                             (type ? type: "undef"), why1, why2, why3);
5950     msgdone:
5951         yyerror(SvPVX(msg));
5952         SvREFCNT_dec(msg);
5953         return sv;
5954     }
5955     cvp = hv_fetch(table, key, strlen(key), FALSE);
5956     if (!cvp || !SvOK(*cvp)) {
5957         why1 = "$^H{";
5958         why2 = key;
5959         why3 = "} is not defined";
5960         goto report;
5961     }
5962     sv_2mortal(sv);                     /* Parent created it permanently */
5963     cv = *cvp;
5964     if (!pv && s)
5965         pv = sv_2mortal(newSVpvn(s, len));
5966     if (type && pv)
5967         typesv = sv_2mortal(newSVpv(type, 0));
5968     else
5969         typesv = &PL_sv_undef;
5970
5971     PUSHSTACKi(PERLSI_OVERLOAD);
5972     ENTER ;
5973     SAVETMPS;
5974
5975     PUSHMARK(SP) ;
5976     EXTEND(sp, 3);
5977     if (pv)
5978         PUSHs(pv);
5979     PUSHs(sv);
5980     if (pv)
5981         PUSHs(typesv);
5982     PUTBACK;
5983     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5984
5985     SPAGAIN ;
5986
5987     /* Check the eval first */
5988     if (!PL_in_eval && SvTRUE(ERRSV)) {
5989         STRLEN n_a;
5990         sv_catpv(ERRSV, "Propagated");
5991         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5992         (void)POPs;
5993         res = SvREFCNT_inc(sv);
5994     }
5995     else {
5996         res = POPs;
5997         (void)SvREFCNT_inc(res);
5998     }
5999
6000     PUTBACK ;
6001     FREETMPS ;
6002     LEAVE ;
6003     POPSTACK;
6004
6005     if (!SvOK(res)) {
6006         why1 = "Call to &{$^H{";
6007         why2 = key;
6008         why3 = "}} did not return a defined value";
6009         sv = res;
6010         goto report;
6011     }
6012
6013     return res;
6014 }
6015
6016 STATIC char *
6017 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6018 {
6019     register char *d = dest;
6020     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6021     for (;;) {
6022         if (d >= e)
6023             Perl_croak(aTHX_ ident_too_long);
6024         if (isALNUM(*s))        /* UTF handled below */
6025             *d++ = *s++;
6026         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6027             *d++ = ':';
6028             *d++ = ':';
6029             s++;
6030         }
6031         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6032             *d++ = *s++;
6033             *d++ = *s++;
6034         }
6035         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6036             char *t = s + UTF8SKIP(s);
6037             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6038                 t += UTF8SKIP(t);
6039             if (d + (t - s) > e)
6040                 Perl_croak(aTHX_ ident_too_long);
6041             Copy(s, d, t - s, char);
6042             d += t - s;
6043             s = t;
6044         }
6045         else {
6046             *d = '\0';
6047             *slp = d - dest;
6048             return s;
6049         }
6050     }
6051 }
6052
6053 STATIC char *
6054 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6055 {
6056     register char *d;
6057     register char *e;
6058     char *bracket = 0;
6059     char funny = *s++;
6060
6061     if (isSPACE(*s))
6062         s = skipspace(s);
6063     d = dest;
6064     e = d + destlen - 3;        /* two-character token, ending NUL */
6065     if (isDIGIT(*s)) {
6066         while (isDIGIT(*s)) {
6067             if (d >= e)
6068                 Perl_croak(aTHX_ ident_too_long);
6069             *d++ = *s++;
6070         }
6071     }
6072     else {
6073         for (;;) {
6074             if (d >= e)
6075                 Perl_croak(aTHX_ ident_too_long);
6076             if (isALNUM(*s))    /* UTF handled below */
6077                 *d++ = *s++;
6078             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6079                 *d++ = ':';
6080                 *d++ = ':';
6081                 s++;
6082             }
6083             else if (*s == ':' && s[1] == ':') {
6084                 *d++ = *s++;
6085                 *d++ = *s++;
6086             }
6087             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6088                 char *t = s + UTF8SKIP(s);
6089                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6090                     t += UTF8SKIP(t);
6091                 if (d + (t - s) > e)
6092                     Perl_croak(aTHX_ ident_too_long);
6093                 Copy(s, d, t - s, char);
6094                 d += t - s;
6095                 s = t;
6096             }
6097             else
6098                 break;
6099         }
6100     }
6101     *d = '\0';
6102     d = dest;
6103     if (*d) {
6104         if (PL_lex_state != LEX_NORMAL)
6105             PL_lex_state = LEX_INTERPENDMAYBE;
6106         return s;
6107     }
6108     if (*s == '$' && s[1] &&
6109         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6110     {
6111         return s;
6112     }
6113     if (*s == '{') {
6114         bracket = s;
6115         s++;
6116     }
6117     else if (ck_uni)
6118         check_uni();
6119     if (s < send)
6120         *d = *s++;
6121     d[1] = '\0';
6122     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6123         *d = toCTRL(*s);
6124         s++;
6125     }
6126     if (bracket) {
6127         if (isSPACE(s[-1])) {
6128             while (s < send) {
6129                 char ch = *s++;
6130                 if (!SPACE_OR_TAB(ch)) {
6131                     *d = ch;
6132                     break;
6133                 }
6134             }
6135         }
6136         if (isIDFIRST_lazy_if(d,UTF)) {
6137             d++;
6138             if (UTF) {
6139                 e = s;
6140                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6141                     e += UTF8SKIP(e);
6142                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6143                         e += UTF8SKIP(e);
6144                 }
6145                 Copy(s, d, e - s, char);
6146                 d += e - s;
6147                 s = e;
6148             }
6149             else {
6150                 while ((isALNUM(*s) || *s == ':') && d < e)
6151                     *d++ = *s++;
6152                 if (d >= e)
6153                     Perl_croak(aTHX_ ident_too_long);
6154             }
6155             *d = '\0';
6156             while (s < send && SPACE_OR_TAB(*s)) s++;
6157             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6158                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6159                     const char *brack = *s == '[' ? "[...]" : "{...}";
6160                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6161                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6162                         funny, dest, brack, funny, dest, brack);
6163                 }
6164                 bracket++;
6165                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6166                 return s;
6167             }
6168         }
6169         /* Handle extended ${^Foo} variables
6170          * 1999-02-27 mjd-perl-patch@plover.com */
6171         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6172                  && isALNUM(*s))
6173         {
6174             d++;
6175             while (isALNUM(*s) && d < e) {
6176                 *d++ = *s++;
6177             }
6178             if (d >= e)
6179                 Perl_croak(aTHX_ ident_too_long);
6180             *d = '\0';
6181         }
6182         if (*s == '}') {
6183             s++;
6184             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6185                 PL_lex_state = LEX_INTERPEND;
6186             if (funny == '#')
6187                 funny = '@';
6188             if (PL_lex_state == LEX_NORMAL) {
6189                 if (ckWARN(WARN_AMBIGUOUS) &&
6190                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6191                 {
6192                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6193                         "Ambiguous use of %c{%s} resolved to %c%s",
6194                         funny, dest, funny, dest);
6195                 }
6196             }
6197         }
6198         else {
6199             s = bracket;                /* let the parser handle it */
6200             *dest = '\0';
6201         }
6202     }
6203     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6204         PL_lex_state = LEX_INTERPEND;
6205     return s;
6206 }
6207
6208 void
6209 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6210 {
6211     if (ch == 'i')
6212         *pmfl |= PMf_FOLD;
6213     else if (ch == 'g')
6214         *pmfl |= PMf_GLOBAL;
6215     else if (ch == 'c')
6216         *pmfl |= PMf_CONTINUE;
6217     else if (ch == 'o')
6218         *pmfl |= PMf_KEEP;
6219     else if (ch == 'm')
6220         *pmfl |= PMf_MULTILINE;
6221     else if (ch == 's')
6222         *pmfl |= PMf_SINGLELINE;
6223     else if (ch == 'x')
6224         *pmfl |= PMf_EXTENDED;
6225 }
6226
6227 STATIC char *
6228 S_scan_pat(pTHX_ char *start, I32 type)
6229 {
6230     PMOP *pm;
6231     char *s;
6232
6233     s = scan_str(start,FALSE,FALSE);
6234     if (!s)
6235         Perl_croak(aTHX_ "Search pattern not terminated");
6236
6237     pm = (PMOP*)newPMOP(type, 0);
6238     if (PL_multi_open == '?')
6239         pm->op_pmflags |= PMf_ONCE;
6240     if(type == OP_QR) {
6241         while (*s && strchr("iomsx", *s))
6242             pmflag(&pm->op_pmflags,*s++);
6243     }
6244     else {
6245         while (*s && strchr("iogcmsx", *s))
6246             pmflag(&pm->op_pmflags,*s++);
6247     }
6248     pm->op_pmpermflags = pm->op_pmflags;
6249
6250     PL_lex_op = (OP*)pm;
6251     yylval.ival = OP_MATCH;
6252     return s;
6253 }
6254
6255 STATIC char *
6256 S_scan_subst(pTHX_ char *start)
6257 {
6258     register char *s;
6259     register PMOP *pm;
6260     I32 first_start;
6261     I32 es = 0;
6262
6263     yylval.ival = OP_NULL;
6264
6265     s = scan_str(start,FALSE,FALSE);
6266
6267     if (!s)
6268         Perl_croak(aTHX_ "Substitution pattern not terminated");
6269
6270     if (s[-1] == PL_multi_open)
6271         s--;
6272
6273     first_start = PL_multi_start;
6274     s = scan_str(s,FALSE,FALSE);
6275     if (!s) {
6276         if (PL_lex_stuff) {
6277             SvREFCNT_dec(PL_lex_stuff);
6278             PL_lex_stuff = Nullsv;
6279         }
6280         Perl_croak(aTHX_ "Substitution replacement not terminated");
6281     }
6282     PL_multi_start = first_start;       /* so whole substitution is taken together */
6283
6284     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6285     while (*s) {
6286         if (*s == 'e') {
6287             s++;
6288             es++;
6289         }
6290         else if (strchr("iogcmsx", *s))
6291             pmflag(&pm->op_pmflags,*s++);
6292         else
6293             break;
6294     }
6295
6296     if (es) {
6297         SV *repl;
6298         PL_sublex_info.super_bufptr = s;
6299         PL_sublex_info.super_bufend = PL_bufend;
6300         PL_multi_end = 0;
6301         pm->op_pmflags |= PMf_EVAL;
6302         repl = newSVpvn("",0);
6303         while (es-- > 0)
6304             sv_catpv(repl, es ? "eval " : "do ");
6305         sv_catpvn(repl, "{ ", 2);
6306         sv_catsv(repl, PL_lex_repl);
6307         sv_catpvn(repl, " };", 2);
6308         SvEVALED_on(repl);
6309         SvREFCNT_dec(PL_lex_repl);
6310         PL_lex_repl = repl;
6311     }
6312
6313     pm->op_pmpermflags = pm->op_pmflags;
6314     PL_lex_op = (OP*)pm;
6315     yylval.ival = OP_SUBST;
6316     return s;
6317 }
6318
6319 STATIC char *
6320 S_scan_trans(pTHX_ char *start)
6321 {
6322     register char* s;
6323     OP *o;
6324     short *tbl;
6325     I32 squash;
6326     I32 del;
6327     I32 complement;
6328
6329     yylval.ival = OP_NULL;
6330
6331     s = scan_str(start,FALSE,FALSE);
6332     if (!s)
6333         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6334     if (s[-1] == PL_multi_open)
6335         s--;
6336
6337     s = scan_str(s,FALSE,FALSE);
6338     if (!s) {
6339         if (PL_lex_stuff) {
6340             SvREFCNT_dec(PL_lex_stuff);
6341             PL_lex_stuff = Nullsv;
6342         }
6343         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6344     }
6345
6346     complement = del = squash = 0;
6347     while (strchr("cds", *s)) {
6348         if (*s == 'c')
6349             complement = OPpTRANS_COMPLEMENT;
6350         else if (*s == 'd')
6351             del = OPpTRANS_DELETE;
6352         else if (*s == 's')
6353             squash = OPpTRANS_SQUASH;
6354         s++;
6355     }
6356
6357     New(803, tbl, complement&&!del?258:256, short);
6358     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6359     o->op_private = del|squash|complement|
6360       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6361       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6362
6363     PL_lex_op = o;
6364     yylval.ival = OP_TRANS;
6365     return s;
6366 }
6367
6368 STATIC char *
6369 S_scan_heredoc(pTHX_ register char *s)
6370 {
6371     SV *herewas;
6372     I32 op_type = OP_SCALAR;
6373     I32 len;
6374     SV *tmpstr;
6375     char term;
6376     register char *d;
6377     register char *e;
6378     char *peek;
6379     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6380
6381     s += 2;
6382     d = PL_tokenbuf;
6383     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6384     if (!outer)
6385         *d++ = '\n';
6386     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6387     if (*peek && strchr("`'\"",*peek)) {
6388         s = peek;
6389         term = *s++;
6390         s = delimcpy(d, e, s, PL_bufend, term, &len);
6391         d += len;
6392         if (s < PL_bufend)
6393             s++;
6394     }
6395     else {
6396         if (*s == '\\')
6397             s++, term = '\'';
6398         else
6399             term = '"';
6400         if (!isALNUM_lazy_if(s,UTF))
6401             deprecate("bare << to mean <<\"\"");
6402         for (; isALNUM_lazy_if(s,UTF); s++) {
6403             if (d < e)
6404                 *d++ = *s;
6405         }
6406     }
6407     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6408         Perl_croak(aTHX_ "Delimiter for here document is too long");
6409     *d++ = '\n';
6410     *d = '\0';
6411     len = d - PL_tokenbuf;
6412 #ifndef PERL_STRICT_CR
6413     d = strchr(s, '\r');
6414     if (d) {
6415         char *olds = s;
6416         s = d;
6417         while (s < PL_bufend) {
6418             if (*s == '\r') {
6419                 *d++ = '\n';
6420                 if (*++s == '\n')
6421                     s++;
6422             }
6423             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6424                 *d++ = *s++;
6425                 s++;
6426             }
6427             else
6428                 *d++ = *s++;
6429         }
6430         *d = '\0';
6431         PL_bufend = d;
6432         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6433         s = olds;
6434     }
6435 #endif
6436     d = "\n";
6437     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6438         herewas = newSVpvn(s,PL_bufend-s);
6439     else
6440         s--, herewas = newSVpvn(s,d-s);
6441     s += SvCUR(herewas);
6442
6443     tmpstr = NEWSV(87,79);
6444     sv_upgrade(tmpstr, SVt_PVIV);
6445     if (term == '\'') {
6446         op_type = OP_CONST;
6447         SvIVX(tmpstr) = -1;
6448     }
6449     else if (term == '`') {
6450         op_type = OP_BACKTICK;
6451         SvIVX(tmpstr) = '\\';
6452     }
6453
6454     CLINE;
6455     PL_multi_start = CopLINE(PL_curcop);
6456     PL_multi_open = PL_multi_close = '<';
6457     term = *PL_tokenbuf;
6458     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6459         char *bufptr = PL_sublex_info.super_bufptr;
6460         char *bufend = PL_sublex_info.super_bufend;
6461         char *olds = s - SvCUR(herewas);
6462         s = strchr(bufptr, '\n');
6463         if (!s)
6464             s = bufend;
6465         d = s;
6466         while (s < bufend &&
6467           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6468             if (*s++ == '\n')
6469                 CopLINE_inc(PL_curcop);
6470         }
6471         if (s >= bufend) {
6472             CopLINE_set(PL_curcop, PL_multi_start);
6473             missingterm(PL_tokenbuf);
6474         }
6475         sv_setpvn(herewas,bufptr,d-bufptr+1);
6476         sv_setpvn(tmpstr,d+1,s-d);
6477         s += len - 1;
6478         sv_catpvn(herewas,s,bufend-s);
6479         (void)strcpy(bufptr,SvPVX(herewas));
6480
6481         s = olds;
6482         goto retval;
6483     }
6484     else if (!outer) {
6485         d = s;
6486         while (s < PL_bufend &&
6487           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6488             if (*s++ == '\n')
6489                 CopLINE_inc(PL_curcop);
6490         }
6491         if (s >= PL_bufend) {
6492             CopLINE_set(PL_curcop, PL_multi_start);
6493             missingterm(PL_tokenbuf);
6494         }
6495         sv_setpvn(tmpstr,d+1,s-d);
6496         s += len - 1;
6497         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6498
6499         sv_catpvn(herewas,s,PL_bufend-s);
6500         sv_setsv(PL_linestr,herewas);
6501         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6502         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6503         PL_last_lop = PL_last_uni = Nullch;
6504     }
6505     else
6506         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6507     while (s >= PL_bufend) {    /* multiple line string? */
6508         if (!outer ||
6509          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6510             CopLINE_set(PL_curcop, PL_multi_start);
6511             missingterm(PL_tokenbuf);
6512         }
6513         CopLINE_inc(PL_curcop);
6514         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6515         PL_last_lop = PL_last_uni = Nullch;
6516 #ifndef PERL_STRICT_CR
6517         if (PL_bufend - PL_linestart >= 2) {
6518             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6519                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6520             {
6521                 PL_bufend[-2] = '\n';
6522                 PL_bufend--;
6523                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6524             }
6525             else if (PL_bufend[-1] == '\r')
6526                 PL_bufend[-1] = '\n';
6527         }
6528         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6529             PL_bufend[-1] = '\n';
6530 #endif
6531         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6532             SV *sv = NEWSV(88,0);
6533
6534             sv_upgrade(sv, SVt_PVMG);
6535             sv_setsv(sv,PL_linestr);
6536             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6537         }
6538         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6539             s = PL_bufend - 1;
6540             *s = ' ';
6541             sv_catsv(PL_linestr,herewas);
6542             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6543         }
6544         else {
6545             s = PL_bufend;
6546             sv_catsv(tmpstr,PL_linestr);
6547         }
6548     }
6549     s++;
6550 retval:
6551     PL_multi_end = CopLINE(PL_curcop);
6552     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6553         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6554         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6555     }
6556     SvREFCNT_dec(herewas);
6557     if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6558         SvUTF8_on(tmpstr);
6559     PL_lex_stuff = tmpstr;
6560     yylval.ival = op_type;
6561     return s;
6562 }
6563
6564 /* scan_inputsymbol
6565    takes: current position in input buffer
6566    returns: new position in input buffer
6567    side-effects: yylval and lex_op are set.
6568
6569    This code handles:
6570
6571    <>           read from ARGV
6572    <FH>         read from filehandle
6573    <pkg::FH>    read from package qualified filehandle
6574    <pkg'FH>     read from package qualified filehandle
6575    <$fh>        read from filehandle in $fh
6576    <*.h>        filename glob
6577
6578 */
6579
6580 STATIC char *
6581 S_scan_inputsymbol(pTHX_ char *start)
6582 {
6583     register char *s = start;           /* current position in buffer */
6584     register char *d;
6585     register char *e;
6586     char *end;
6587     I32 len;
6588
6589     d = PL_tokenbuf;                    /* start of temp holding space */
6590     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6591     end = strchr(s, '\n');
6592     if (!end)
6593         end = PL_bufend;
6594     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6595
6596     /* die if we didn't have space for the contents of the <>,
6597        or if it didn't end, or if we see a newline
6598     */
6599
6600     if (len >= sizeof PL_tokenbuf)
6601         Perl_croak(aTHX_ "Excessively long <> operator");
6602     if (s >= end)
6603         Perl_croak(aTHX_ "Unterminated <> operator");
6604
6605     s++;
6606
6607     /* check for <$fh>
6608        Remember, only scalar variables are interpreted as filehandles by
6609        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6610        treated as a glob() call.
6611        This code makes use of the fact that except for the $ at the front,
6612        a scalar variable and a filehandle look the same.
6613     */
6614     if (*d == '$' && d[1]) d++;
6615
6616     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6617     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6618         d++;
6619
6620     /* If we've tried to read what we allow filehandles to look like, and
6621        there's still text left, then it must be a glob() and not a getline.
6622        Use scan_str to pull out the stuff between the <> and treat it
6623        as nothing more than a string.
6624     */
6625
6626     if (d - PL_tokenbuf != len) {
6627         yylval.ival = OP_GLOB;
6628         set_csh();
6629         s = scan_str(start,FALSE,FALSE);
6630         if (!s)
6631            Perl_croak(aTHX_ "Glob not terminated");
6632         return s;
6633     }
6634     else {
6635         /* we're in a filehandle read situation */
6636         d = PL_tokenbuf;
6637
6638         /* turn <> into <ARGV> */
6639         if (!len)
6640             (void)strcpy(d,"ARGV");
6641
6642         /* if <$fh>, create the ops to turn the variable into a
6643            filehandle
6644         */
6645         if (*d == '$') {
6646             I32 tmp;
6647
6648             /* try to find it in the pad for this block, otherwise find
6649                add symbol table ops
6650             */
6651             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6652                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6653                 if (SvFLAGS(namesv) & SVpad_OUR) {
6654                     SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6655                     sv_catpvn(sym, "::", 2);
6656                     sv_catpv(sym, d+1);
6657                     d = SvPVX(sym);
6658                     goto intro_sym;
6659                 }
6660                 else {
6661                     OP *o = newOP(OP_PADSV, 0);
6662                     o->op_targ = tmp;
6663                     PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6664                 }
6665             }
6666             else {
6667                 GV *gv;
6668                 ++d;
6669 intro_sym:
6670                 gv = gv_fetchpv(d,
6671                                 (PL_in_eval
6672                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6673                                  : TRUE),
6674                                 SVt_PV);
6675                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6676                                             newUNOP(OP_RV2SV, 0,
6677                                                 newGVOP(OP_GV, 0, gv)));
6678             }
6679             PL_lex_op->op_flags |= OPf_SPECIAL;
6680             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6681             yylval.ival = OP_NULL;
6682         }
6683
6684         /* If it's none of the above, it must be a literal filehandle
6685            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6686         else {
6687             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6688             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6689             yylval.ival = OP_NULL;
6690         }
6691     }
6692
6693     return s;
6694 }
6695
6696
6697 /* scan_str
6698    takes: start position in buffer
6699           keep_quoted preserve \ on the embedded delimiter(s)
6700           keep_delims preserve the delimiters around the string
6701    returns: position to continue reading from buffer
6702    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6703         updates the read buffer.
6704
6705    This subroutine pulls a string out of the input.  It is called for:
6706         q               single quotes           q(literal text)
6707         '               single quotes           'literal text'
6708         qq              double quotes           qq(interpolate $here please)
6709         "               double quotes           "interpolate $here please"
6710         qx              backticks               qx(/bin/ls -l)
6711         `               backticks               `/bin/ls -l`
6712         qw              quote words             @EXPORT_OK = qw( func() $spam )
6713         m//             regexp match            m/this/
6714         s///            regexp substitute       s/this/that/
6715         tr///           string transliterate    tr/this/that/
6716         y///            string transliterate    y/this/that/
6717         ($*@)           sub prototypes          sub foo ($)
6718         (stuff)         sub attr parameters     sub foo : attr(stuff)
6719         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6720
6721    In most of these cases (all but <>, patterns and transliterate)
6722    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6723    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6724    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6725    calls scan_str().
6726
6727    It skips whitespace before the string starts, and treats the first
6728    character as the delimiter.  If the delimiter is one of ([{< then
6729    the corresponding "close" character )]}> is used as the closing
6730    delimiter.  It allows quoting of delimiters, and if the string has
6731    balanced delimiters ([{<>}]) it allows nesting.
6732
6733    On success, the SV with the resulting string is put into lex_stuff or,
6734    if that is already non-NULL, into lex_repl. The second case occurs only
6735    when parsing the RHS of the special constructs s/// and tr/// (y///).
6736    For convenience, the terminating delimiter character is stuffed into
6737    SvIVX of the SV.
6738 */
6739
6740 STATIC char *
6741 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6742 {
6743     SV *sv;                             /* scalar value: string */
6744     char *tmps;                         /* temp string, used for delimiter matching */
6745     register char *s = start;           /* current position in the buffer */
6746     register char term;                 /* terminating character */
6747     register char *to;                  /* current position in the sv's data */
6748     I32 brackets = 1;                   /* bracket nesting level */
6749     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6750
6751     /* skip space before the delimiter */
6752     if (isSPACE(*s))
6753         s = skipspace(s);
6754
6755     /* mark where we are, in case we need to report errors */
6756     CLINE;
6757
6758     /* after skipping whitespace, the next character is the terminator */
6759     term = *s;
6760     if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6761         has_utf8 = TRUE;
6762
6763     /* mark where we are */
6764     PL_multi_start = CopLINE(PL_curcop);
6765     PL_multi_open = term;
6766
6767     /* find corresponding closing delimiter */
6768     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6769         term = tmps[5];
6770     PL_multi_close = term;
6771
6772     /* create a new SV to hold the contents.  87 is leak category, I'm
6773        assuming.  79 is the SV's initial length.  What a random number. */
6774     sv = NEWSV(87,79);
6775     sv_upgrade(sv, SVt_PVIV);
6776     SvIVX(sv) = term;
6777     (void)SvPOK_only(sv);               /* validate pointer */
6778
6779     /* move past delimiter and try to read a complete string */
6780     if (keep_delims)
6781         sv_catpvn(sv, s, 1);
6782     s++;
6783     for (;;) {
6784         /* extend sv if need be */
6785         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6786         /* set 'to' to the next character in the sv's string */
6787         to = SvPVX(sv)+SvCUR(sv);
6788
6789         /* if open delimiter is the close delimiter read unbridle */
6790         if (PL_multi_open == PL_multi_close) {
6791             for (; s < PL_bufend; s++,to++) {
6792                 /* embedded newlines increment the current line number */
6793                 if (*s == '\n' && !PL_rsfp)
6794                     CopLINE_inc(PL_curcop);
6795                 /* handle quoted delimiters */
6796                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6797                     if (!keep_quoted && s[1] == term)
6798                         s++;
6799                 /* any other quotes are simply copied straight through */
6800                     else
6801                         *to++ = *s++;
6802                 }
6803                 /* terminate when run out of buffer (the for() condition), or
6804                    have found the terminator */
6805                 else if (*s == term)
6806                     break;
6807                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6808                     has_utf8 = TRUE;
6809                 *to = *s;
6810             }
6811         }
6812
6813         /* if the terminator isn't the same as the start character (e.g.,
6814            matched brackets), we have to allow more in the quoting, and
6815            be prepared for nested brackets.
6816         */
6817         else {
6818             /* read until we run out of string, or we find the terminator */
6819             for (; s < PL_bufend; s++,to++) {
6820                 /* embedded newlines increment the line count */
6821                 if (*s == '\n' && !PL_rsfp)
6822                     CopLINE_inc(PL_curcop);
6823                 /* backslashes can escape the open or closing characters */
6824                 if (*s == '\\' && s+1 < PL_bufend) {
6825                     if (!keep_quoted &&
6826                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6827                         s++;
6828                     else
6829                         *to++ = *s++;
6830                 }
6831                 /* allow nested opens and closes */
6832                 else if (*s == PL_multi_close && --brackets <= 0)
6833                     break;
6834                 else if (*s == PL_multi_open)
6835                     brackets++;
6836                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6837                     has_utf8 = TRUE;
6838                 *to = *s;
6839             }
6840         }
6841         /* terminate the copied string and update the sv's end-of-string */
6842         *to = '\0';
6843         SvCUR_set(sv, to - SvPVX(sv));
6844
6845         /*
6846          * this next chunk reads more into the buffer if we're not done yet
6847          */
6848
6849         if (s < PL_bufend)
6850             break;              /* handle case where we are done yet :-) */
6851
6852 #ifndef PERL_STRICT_CR
6853         if (to - SvPVX(sv) >= 2) {
6854             if ((to[-2] == '\r' && to[-1] == '\n') ||
6855                 (to[-2] == '\n' && to[-1] == '\r'))
6856             {
6857                 to[-2] = '\n';
6858                 to--;
6859                 SvCUR_set(sv, to - SvPVX(sv));
6860             }
6861             else if (to[-1] == '\r')
6862                 to[-1] = '\n';
6863         }
6864         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6865             to[-1] = '\n';
6866 #endif
6867
6868         /* if we're out of file, or a read fails, bail and reset the current
6869            line marker so we can report where the unterminated string began
6870         */
6871         if (!PL_rsfp ||
6872          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6873             sv_free(sv);
6874             CopLINE_set(PL_curcop, PL_multi_start);
6875             return Nullch;
6876         }
6877         /* we read a line, so increment our line counter */
6878         CopLINE_inc(PL_curcop);
6879
6880         /* update debugger info */
6881         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6882             SV *sv = NEWSV(88,0);
6883
6884             sv_upgrade(sv, SVt_PVMG);
6885             sv_setsv(sv,PL_linestr);
6886             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6887         }
6888
6889         /* having changed the buffer, we must update PL_bufend */
6890         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6891         PL_last_lop = PL_last_uni = Nullch;
6892     }
6893
6894     /* at this point, we have successfully read the delimited string */
6895
6896     if (keep_delims)
6897         sv_catpvn(sv, s, 1);
6898     if (has_utf8)
6899         SvUTF8_on(sv);
6900     PL_multi_end = CopLINE(PL_curcop);
6901     s++;
6902
6903     /* if we allocated too much space, give some back */
6904     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6905         SvLEN_set(sv, SvCUR(sv) + 1);
6906         Renew(SvPVX(sv), SvLEN(sv), char);
6907     }
6908
6909     /* decide whether this is the first or second quoted string we've read
6910        for this op
6911     */
6912
6913     if (PL_lex_stuff)
6914         PL_lex_repl = sv;
6915     else
6916         PL_lex_stuff = sv;
6917     return s;
6918 }
6919
6920 /*
6921   scan_num
6922   takes: pointer to position in buffer
6923   returns: pointer to new position in buffer
6924   side-effects: builds ops for the constant in yylval.op
6925
6926   Read a number in any of the formats that Perl accepts:
6927
6928   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
6929   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
6930   0b[01](_?[01])*
6931   0[0-7](_?[0-7])*
6932   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6933
6934   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6935   thing it reads.
6936
6937   If it reads a number without a decimal point or an exponent, it will
6938   try converting the number to an integer and see if it can do so
6939   without loss of precision.
6940 */
6941
6942 char *
6943 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6944 {
6945     register char *s = start;           /* current position in buffer */
6946     register char *d;                   /* destination in temp buffer */
6947     register char *e;                   /* end of temp buffer */
6948     NV nv;                              /* number read, as a double */
6949     SV *sv = Nullsv;                    /* place to put the converted number */
6950     bool floatit;                       /* boolean: int or float? */
6951     char *lastub = 0;                   /* position of last underbar */
6952     static char number_too_long[] = "Number too long";
6953
6954     /* We use the first character to decide what type of number this is */
6955
6956     switch (*s) {
6957     default:
6958       Perl_croak(aTHX_ "panic: scan_num");
6959
6960     /* if it starts with a 0, it could be an octal number, a decimal in
6961        0.13 disguise, or a hexadecimal number, or a binary number. */
6962     case '0':
6963         {
6964           /* variables:
6965              u          holds the "number so far"
6966              shift      the power of 2 of the base
6967                         (hex == 4, octal == 3, binary == 1)
6968              overflowed was the number more than we can hold?
6969
6970              Shift is used when we add a digit.  It also serves as an "are
6971              we in octal/hex/binary?" indicator to disallow hex characters
6972              when in octal mode.
6973            */
6974             NV n = 0.0;
6975             UV u = 0;
6976             I32 shift;
6977             bool overflowed = FALSE;
6978             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6979             static char* bases[5] = { "", "binary", "", "octal",
6980                                       "hexadecimal" };
6981             static char* Bases[5] = { "", "Binary", "", "Octal",
6982                                       "Hexadecimal" };
6983             static char *maxima[5] = { "",
6984                                        "0b11111111111111111111111111111111",
6985                                        "",
6986                                        "037777777777",
6987                                        "0xffffffff" };
6988             char *base, *Base, *max;
6989
6990             /* check for hex */
6991             if (s[1] == 'x') {
6992                 shift = 4;
6993                 s += 2;
6994             } else if (s[1] == 'b') {
6995                 shift = 1;
6996                 s += 2;
6997             }
6998             /* check for a decimal in disguise */
6999             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7000                 goto decimal;
7001             /* so it must be octal */
7002             else {
7003                 shift = 3;
7004                 s++;
7005             }
7006
7007             if (*s == '_') {
7008                if (ckWARN(WARN_SYNTAX))
7009                    Perl_warner(aTHX_ WARN_SYNTAX,
7010                                "Misplaced _ in number");
7011                lastub = s++;
7012             }
7013
7014             base = bases[shift];
7015             Base = Bases[shift];
7016             max  = maxima[shift];
7017
7018             /* read the rest of the number */
7019             for (;;) {
7020                 /* x is used in the overflow test,
7021                    b is the digit we're adding on. */
7022                 UV x, b;
7023
7024                 switch (*s) {
7025
7026                 /* if we don't mention it, we're done */
7027                 default:
7028                     goto out;
7029
7030                 /* _ are ignored -- but warned about if consecutive */
7031                 case '_':
7032                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7033                         Perl_warner(aTHX_ WARN_SYNTAX,
7034                                     "Misplaced _ in number");
7035                     lastub = s++;
7036                     break;
7037
7038                 /* 8 and 9 are not octal */
7039                 case '8': case '9':
7040                     if (shift == 3)
7041                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7042                     /* FALL THROUGH */
7043
7044                 /* octal digits */
7045                 case '2': case '3': case '4':
7046                 case '5': case '6': case '7':
7047                     if (shift == 1)
7048                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7049                     /* FALL THROUGH */
7050
7051                 case '0': case '1':
7052                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7053                     goto digit;
7054
7055                 /* hex digits */
7056                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7057                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7058                     /* make sure they said 0x */
7059                     if (shift != 4)
7060                         goto out;
7061                     b = (*s++ & 7) + 9;
7062
7063                     /* Prepare to put the digit we have onto the end
7064                        of the number so far.  We check for overflows.
7065                     */
7066
7067                   digit:
7068                     if (!overflowed) {
7069                         x = u << shift; /* make room for the digit */
7070
7071                         if ((x >> shift) != u
7072                             && !(PL_hints & HINT_NEW_BINARY)) {
7073                             overflowed = TRUE;
7074                             n = (NV) u;
7075                             if (ckWARN_d(WARN_OVERFLOW))
7076                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7077                                             "Integer overflow in %s number",
7078                                             base);
7079                         } else
7080                             u = x | b;          /* add the digit to the end */
7081                     }
7082                     if (overflowed) {
7083                         n *= nvshift[shift];
7084                         /* If an NV has not enough bits in its
7085                          * mantissa to represent an UV this summing of
7086                          * small low-order numbers is a waste of time
7087                          * (because the NV cannot preserve the
7088                          * low-order bits anyway): we could just
7089                          * remember when did we overflow and in the
7090                          * end just multiply n by the right
7091                          * amount. */
7092                         n += (NV) b;
7093                     }
7094                     break;
7095                 }
7096             }
7097
7098           /* if we get here, we had success: make a scalar value from
7099              the number.
7100           */
7101           out:
7102
7103             /* final misplaced underbar check */
7104             if (s[-1] == '_') {
7105                 if (ckWARN(WARN_SYNTAX))
7106                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7107             }
7108
7109             sv = NEWSV(92,0);
7110             if (overflowed) {
7111                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7112                     Perl_warner(aTHX_ WARN_PORTABLE,
7113                                 "%s number > %s non-portable",
7114                                 Base, max);
7115                 sv_setnv(sv, n);
7116             }
7117             else {
7118 #if UVSIZE > 4
7119                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7120                     Perl_warner(aTHX_ WARN_PORTABLE,
7121                                 "%s number > %s non-portable",
7122                                 Base, max);
7123 #endif
7124                 sv_setuv(sv, u);
7125             }
7126             if (PL_hints & HINT_NEW_BINARY)
7127                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7128         }
7129         break;
7130
7131     /*
7132       handle decimal numbers.
7133       we're also sent here when we read a 0 as the first digit
7134     */
7135     case '1': case '2': case '3': case '4': case '5':
7136     case '6': case '7': case '8': case '9': case '.':
7137       decimal:
7138         d = PL_tokenbuf;
7139         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7140         floatit = FALSE;
7141
7142         /* read next group of digits and _ and copy into d */
7143         while (isDIGIT(*s) || *s == '_') {
7144             /* skip underscores, checking for misplaced ones
7145                if -w is on
7146             */
7147             if (*s == '_') {
7148                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7149                     Perl_warner(aTHX_ WARN_SYNTAX,
7150                                 "Misplaced _ in number");
7151                 lastub = s++;
7152             }
7153             else {
7154                 /* check for end of fixed-length buffer */
7155                 if (d >= e)
7156                     Perl_croak(aTHX_ number_too_long);
7157                 /* if we're ok, copy the character */
7158                 *d++ = *s++;
7159             }
7160         }
7161
7162         /* final misplaced underbar check */
7163         if (lastub && s == lastub + 1) {
7164             if (ckWARN(WARN_SYNTAX))
7165                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7166         }
7167
7168         /* read a decimal portion if there is one.  avoid
7169            3..5 being interpreted as the number 3. followed
7170            by .5
7171         */
7172         if (*s == '.' && s[1] != '.') {
7173             floatit = TRUE;
7174             *d++ = *s++;
7175
7176             if (*s == '_') {
7177                 if (ckWARN(WARN_SYNTAX))
7178                     Perl_warner(aTHX_ WARN_SYNTAX,
7179                                 "Misplaced _ in number");
7180                 lastub = s;
7181             }
7182
7183             /* copy, ignoring underbars, until we run out of digits.
7184             */
7185             for (; isDIGIT(*s) || *s == '_'; s++) {
7186                 /* fixed length buffer check */
7187                 if (d >= e)
7188                     Perl_croak(aTHX_ number_too_long);
7189                 if (*s == '_') {
7190                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7191                        Perl_warner(aTHX_ WARN_SYNTAX,
7192                                    "Misplaced _ in number");
7193                    lastub = s;
7194                 }
7195                 else
7196                     *d++ = *s;
7197             }
7198             /* fractional part ending in underbar? */
7199             if (s[-1] == '_') {
7200                 if (ckWARN(WARN_SYNTAX))
7201                     Perl_warner(aTHX_ WARN_SYNTAX,
7202                                 "Misplaced _ in number");
7203             }
7204             if (*s == '.' && isDIGIT(s[1])) {
7205                 /* oops, it's really a v-string, but without the "v" */
7206                 s = start - 1;
7207                 goto vstring;
7208             }
7209         }
7210
7211         /* read exponent part, if present */
7212         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7213             floatit = TRUE;
7214             s++;
7215
7216             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7217             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7218
7219             /* stray preinitial _ */
7220             if (*s == '_') {
7221                 if (ckWARN(WARN_SYNTAX))
7222                     Perl_warner(aTHX_ WARN_SYNTAX,
7223                                 "Misplaced _ in number");
7224                 lastub = s++;
7225             }
7226
7227             /* allow positive or negative exponent */
7228             if (*s == '+' || *s == '-')
7229                 *d++ = *s++;
7230
7231             /* stray initial _ */
7232             if (*s == '_') {
7233                 if (ckWARN(WARN_SYNTAX))
7234                     Perl_warner(aTHX_ WARN_SYNTAX,
7235                                 "Misplaced _ in number");
7236                 lastub = s++;
7237             }
7238
7239             /* read digits of exponent */
7240             while (isDIGIT(*s) || *s == '_') {
7241                 if (isDIGIT(*s)) {
7242                     if (d >= e)
7243                         Perl_croak(aTHX_ number_too_long);
7244                     *d++ = *s++;
7245                 }
7246                 else {
7247                    if (ckWARN(WARN_SYNTAX) &&
7248                        ((lastub && s == lastub + 1) ||
7249                         (!isDIGIT(s[1]) && s[1] != '_')))
7250                        Perl_warner(aTHX_ WARN_SYNTAX,
7251                                    "Misplaced _ in number");
7252                    lastub = s++;
7253                 }
7254             }
7255         }
7256
7257
7258         /* make an sv from the string */
7259         sv = NEWSV(92,0);
7260
7261         /*
7262            We try to do an integer conversion first if no characters
7263            indicating "float" have been found.
7264          */
7265
7266         if (!floatit) {
7267             UV uv;
7268             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7269
7270             if (flags == IS_NUMBER_IN_UV) {
7271               if (uv <= IV_MAX)
7272                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7273               else
7274                 sv_setuv(sv, uv);
7275             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7276               if (uv <= (UV) IV_MIN)
7277                 sv_setiv(sv, -(IV)uv);
7278               else
7279                 floatit = TRUE;
7280             } else
7281               floatit = TRUE;
7282         }
7283         if (floatit) {
7284             /* terminate the string */
7285             *d = '\0';
7286             nv = Atof(PL_tokenbuf);
7287             sv_setnv(sv, nv);
7288         }
7289
7290         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7291                        (PL_hints & HINT_NEW_INTEGER) )
7292             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7293                               (floatit ? "float" : "integer"),
7294                               sv, Nullsv, NULL);
7295         break;
7296
7297     /* if it starts with a v, it could be a v-string */
7298     case 'v':
7299 vstring:
7300         {
7301             char *pos = s;
7302             pos++;
7303             while (isDIGIT(*pos) || *pos == '_')
7304                 pos++;
7305             if (!isALPHA(*pos)) {
7306                 UV rev;
7307                 U8 tmpbuf[UTF8_MAXLEN+1];
7308                 U8 *tmpend;
7309                 s++;                            /* get past 'v' */
7310
7311                 sv = NEWSV(92,5);
7312                 sv_setpvn(sv, "", 0);
7313
7314                 for (;;) {
7315                     if (*s == '0' && isDIGIT(s[1]))
7316                         yyerror("Octal number in vector unsupported");
7317                     rev = 0;
7318                     {
7319                         /* this is atoi() that tolerates underscores */
7320                         char *end = pos;
7321                         UV mult = 1;
7322                         while (--end >= s) {
7323                             UV orev;
7324                             if (*end == '_')
7325                                 continue;
7326                             orev = rev;
7327                             rev += (*end - '0') * mult;
7328                             mult *= 10;
7329                             if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7330                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7331                                             "Integer overflow in decimal number");
7332                         }
7333                     }
7334                     /* Append native character for the rev point */
7335                     tmpend = uvchr_to_utf8(tmpbuf, rev);
7336                     sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7337                     if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
7338                         SvUTF8_on(sv);
7339                     if (*pos == '.' && isDIGIT(pos[1]))
7340                         s = ++pos;
7341                     else {
7342                         s = pos;
7343                         break;
7344                     }
7345                     while (isDIGIT(*pos) || *pos == '_')
7346                         pos++;
7347                 }
7348                 SvPOK_on(sv);
7349                 SvREADONLY_on(sv);
7350             }
7351         }
7352         break;
7353     }
7354
7355     /* make the op for the constant and return */
7356
7357     if (sv)
7358         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7359     else
7360         lvalp->opval = Nullop;
7361
7362     return s;
7363 }
7364
7365 STATIC char *
7366 S_scan_formline(pTHX_ register char *s)
7367 {
7368     register char *eol;
7369     register char *t;
7370     SV *stuff = newSVpvn("",0);
7371     bool needargs = FALSE;
7372
7373     while (!needargs) {
7374         if (*s == '.' || *s == /*{*/'}') {
7375             /*SUPPRESS 530*/
7376 #ifdef PERL_STRICT_CR
7377             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7378 #else
7379             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7380 #endif
7381             if (*t == '\n' || t == PL_bufend)
7382                 break;
7383         }
7384         if (PL_in_eval && !PL_rsfp) {
7385             eol = strchr(s,'\n');
7386             if (!eol++)
7387                 eol = PL_bufend;
7388         }
7389         else
7390             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7391         if (*s != '#') {
7392             for (t = s; t < eol; t++) {
7393                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7394                     needargs = FALSE;
7395                     goto enough;        /* ~~ must be first line in formline */
7396                 }
7397                 if (*t == '@' || *t == '^')
7398                     needargs = TRUE;
7399             }
7400             if (eol > s) {
7401                 sv_catpvn(stuff, s, eol-s);
7402 #ifndef PERL_STRICT_CR
7403                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7404                     char *end = SvPVX(stuff) + SvCUR(stuff);
7405                     end[-2] = '\n';
7406                     end[-1] = '\0';
7407                     SvCUR(stuff)--;
7408                 }
7409 #endif
7410             }
7411             else
7412               break;
7413         }
7414         s = eol;
7415         if (PL_rsfp) {
7416             s = filter_gets(PL_linestr, PL_rsfp, 0);
7417             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7418             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7419             PL_last_lop = PL_last_uni = Nullch;
7420             if (!s) {
7421                 s = PL_bufptr;
7422                 yyerror("Format not terminated");
7423                 break;
7424             }
7425         }
7426         incline(s);
7427     }
7428   enough:
7429     if (SvCUR(stuff)) {
7430         PL_expect = XTERM;
7431         if (needargs) {
7432             PL_lex_state = LEX_NORMAL;
7433             PL_nextval[PL_nexttoke].ival = 0;
7434             force_next(',');
7435         }
7436         else
7437             PL_lex_state = LEX_FORMLINE;
7438         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7439         force_next(THING);
7440         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7441         force_next(LSTOP);
7442     }
7443     else {
7444         SvREFCNT_dec(stuff);
7445         PL_lex_formbrack = 0;
7446         PL_bufptr = s;
7447     }
7448     return s;
7449 }
7450
7451 STATIC void
7452 S_set_csh(pTHX)
7453 {
7454 #ifdef CSH
7455     if (!PL_cshlen)
7456         PL_cshlen = strlen(PL_cshname);
7457 #endif
7458 }
7459
7460 I32
7461 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7462 {
7463     I32 oldsavestack_ix = PL_savestack_ix;
7464     CV* outsidecv = PL_compcv;
7465     AV* comppadlist;
7466
7467     if (PL_compcv) {
7468         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7469     }
7470     SAVEI32(PL_subline);
7471     save_item(PL_subname);
7472     SAVEI32(PL_padix);
7473     SAVECOMPPAD();
7474     SAVESPTR(PL_comppad_name);
7475     SAVESPTR(PL_compcv);
7476     SAVEI32(PL_comppad_name_fill);
7477     SAVEI32(PL_min_intro_pending);
7478     SAVEI32(PL_max_intro_pending);
7479     SAVEI32(PL_pad_reset_pending);
7480
7481     PL_compcv = (CV*)NEWSV(1104,0);
7482     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7483     CvFLAGS(PL_compcv) |= flags;
7484
7485     PL_comppad = newAV();
7486     av_push(PL_comppad, Nullsv);
7487     PL_curpad = AvARRAY(PL_comppad);
7488     PL_comppad_name = newAV();
7489     PL_comppad_name_fill = 0;
7490     PL_min_intro_pending = 0;
7491     PL_padix = 0;
7492     PL_subline = CopLINE(PL_curcop);
7493 #ifdef USE_5005THREADS
7494     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7495     PL_curpad[0] = (SV*)newAV();
7496     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7497 #endif /* USE_5005THREADS */
7498
7499     comppadlist = newAV();
7500     AvREAL_off(comppadlist);
7501     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7502     av_store(comppadlist, 1, (SV*)PL_comppad);
7503
7504     CvPADLIST(PL_compcv) = comppadlist;
7505     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7506 #ifdef USE_5005THREADS
7507     CvOWNER(PL_compcv) = 0;
7508     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7509     MUTEX_INIT(CvMUTEXP(PL_compcv));
7510 #endif /* USE_5005THREADS */
7511
7512     return oldsavestack_ix;
7513 }
7514
7515 #ifdef __SC__
7516 #pragma segment Perl_yylex
7517 #endif
7518 int
7519 Perl_yywarn(pTHX_ char *s)
7520 {
7521     PL_in_eval |= EVAL_WARNONLY;
7522     yyerror(s);
7523     PL_in_eval &= ~EVAL_WARNONLY;
7524     return 0;
7525 }
7526
7527 int
7528 Perl_yyerror(pTHX_ char *s)
7529 {
7530     char *where = NULL;
7531     char *context = NULL;
7532     int contlen = -1;
7533     SV *msg;
7534
7535     if (!yychar || (yychar == ';' && !PL_rsfp))
7536         where = "at EOF";
7537     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7538       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7539         while (isSPACE(*PL_oldoldbufptr))
7540             PL_oldoldbufptr++;
7541         context = PL_oldoldbufptr;
7542         contlen = PL_bufptr - PL_oldoldbufptr;
7543     }
7544     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7545       PL_oldbufptr != PL_bufptr) {
7546         while (isSPACE(*PL_oldbufptr))
7547             PL_oldbufptr++;
7548         context = PL_oldbufptr;
7549         contlen = PL_bufptr - PL_oldbufptr;
7550     }
7551     else if (yychar > 255)
7552         where = "next token ???";
7553 #ifdef USE_PURE_BISON
7554 /*  GNU Bison sets the value -2 */
7555     else if (yychar == -2) {
7556 #else
7557     else if ((yychar & 127) == 127) {
7558 #endif
7559         if (PL_lex_state == LEX_NORMAL ||
7560            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7561             where = "at end of line";
7562         else if (PL_lex_inpat)
7563             where = "within pattern";
7564         else
7565             where = "within string";
7566     }
7567     else {
7568         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7569         if (yychar < 32)
7570             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7571         else if (isPRINT_LC(yychar))
7572             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7573         else
7574             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7575         where = SvPVX(where_sv);
7576     }
7577     msg = sv_2mortal(newSVpv(s, 0));
7578     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7579                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7580     if (context)
7581         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7582     else
7583         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7584     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7585         Perl_sv_catpvf(aTHX_ msg,
7586         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7587                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7588         PL_multi_end = 0;
7589     }
7590     if (PL_in_eval & EVAL_WARNONLY)
7591         Perl_warn(aTHX_ "%"SVf, msg);
7592     else
7593         qerror(msg);
7594     if (PL_error_count >= 10) {
7595         if (PL_in_eval && SvCUR(ERRSV))
7596             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7597                        ERRSV, CopFILE(PL_curcop));
7598         else
7599             Perl_croak(aTHX_ "%s has too many errors.\n",
7600                        CopFILE(PL_curcop));
7601     }
7602     PL_in_my = 0;
7603     PL_in_my_stash = Nullhv;
7604     return 0;
7605 }
7606 #ifdef __SC__
7607 #pragma segment Main
7608 #endif
7609
7610 STATIC char*
7611 S_swallow_bom(pTHX_ U8 *s)
7612 {
7613     STRLEN slen;
7614     slen = SvCUR(PL_linestr);
7615     switch (*s) {
7616     case 0xFF:
7617         if (s[1] == 0xFE) {
7618             /* UTF-16 little-endian */
7619             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7620                 Perl_croak(aTHX_ "Unsupported script encoding");
7621 #ifndef PERL_NO_UTF16_FILTER
7622             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7623             s += 2;
7624             if (PL_bufend > (char*)s) {
7625                 U8 *news;
7626                 I32 newlen;
7627
7628                 filter_add(utf16rev_textfilter, NULL);
7629                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7630                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7631                                                  PL_bufend - (char*)s - 1,
7632                                                  &newlen);
7633                 Copy(news, s, newlen, U8);
7634                 SvCUR_set(PL_linestr, newlen);
7635                 PL_bufend = SvPVX(PL_linestr) + newlen;
7636                 news[newlen++] = '\0';
7637                 Safefree(news);
7638             }
7639 #else
7640             Perl_croak(aTHX_ "Unsupported script encoding");
7641 #endif
7642         }
7643         break;
7644     case 0xFE:
7645         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7646 #ifndef PERL_NO_UTF16_FILTER
7647             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7648             s += 2;
7649             if (PL_bufend > (char *)s) {
7650                 U8 *news;
7651                 I32 newlen;
7652
7653                 filter_add(utf16_textfilter, NULL);
7654                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7655                 PL_bufend = (char*)utf16_to_utf8(s, news,
7656                                                  PL_bufend - (char*)s,
7657                                                  &newlen);
7658                 Copy(news, s, newlen, U8);
7659                 SvCUR_set(PL_linestr, newlen);
7660                 PL_bufend = SvPVX(PL_linestr) + newlen;
7661                 news[newlen++] = '\0';
7662                 Safefree(news);
7663             }
7664 #else
7665             Perl_croak(aTHX_ "Unsupported script encoding");
7666 #endif
7667         }
7668         break;
7669     case 0xEF:
7670         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7671             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7672             s += 3;                      /* UTF-8 */
7673         }
7674         break;
7675     case 0:
7676         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7677             s[2] == 0xFE && s[3] == 0xFF)
7678         {
7679             Perl_croak(aTHX_ "Unsupported script encoding");
7680         }
7681     }
7682     return (char*)s;
7683 }
7684
7685 /*
7686  * restore_rsfp
7687  * Restore a source filter.
7688  */
7689
7690 static void
7691 restore_rsfp(pTHX_ void *f)
7692 {
7693     PerlIO *fp = (PerlIO*)f;
7694
7695     if (PL_rsfp == PerlIO_stdin())
7696         PerlIO_clearerr(PL_rsfp);
7697     else if (PL_rsfp && (PL_rsfp != fp))
7698         PerlIO_close(PL_rsfp);
7699     PL_rsfp = fp;
7700 }
7701
7702 #ifndef PERL_NO_UTF16_FILTER
7703 static I32
7704 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7705 {
7706     I32 count = FILTER_READ(idx+1, sv, maxlen);
7707     if (count) {
7708         U8* tmps;
7709         U8* tend;
7710         I32 newlen;
7711         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7712         if (!*SvPV_nolen(sv))
7713         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7714         return count;
7715
7716         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7717         sv_usepvn(sv, (char*)tmps, tend - tmps);
7718     }
7719     return count;
7720 }
7721
7722 static I32
7723 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7724 {
7725     I32 count = FILTER_READ(idx+1, sv, maxlen);
7726     if (count) {
7727         U8* tmps;
7728         U8* tend;
7729         I32 newlen;
7730         if (!*SvPV_nolen(sv))
7731         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7732         return count;
7733
7734         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7735         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7736         sv_usepvn(sv, (char*)tmps, tend - tmps);
7737     }
7738     return count;
7739 }
7740 #endif
7741