toke.c

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