toke.c

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