toke.c

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