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