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