toke.c

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