toke.c

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