toke.c

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