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