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