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