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