toke.c

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