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