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