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