toke.c

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