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