toke.c

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