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