toke.c

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