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