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