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