toke.c

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