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