toke.c

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