toke.c

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