toke.c

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