toke.c

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