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