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