toke.c

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