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