toke.c

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