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