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