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