toke.c

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