toke.c

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