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