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