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