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 wsallow_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,"EQ")) { deprecate(d);      return -KEY_eq;}
5150         if (strEQ(d,"END"))                     return KEY_END;
5151         break;
5152     case 'e':
5153         switch (len) {
5154         case 2:
5155             if (strEQ(d,"eq"))                  return -KEY_eq;
5156             break;
5157         case 3:
5158             if (strEQ(d,"eof"))                 return -KEY_eof;
5159             if (strEQ(d,"exp"))                 return -KEY_exp;
5160             break;
5161         case 4:
5162             if (strEQ(d,"else"))                return KEY_else;
5163             if (strEQ(d,"exit"))                return -KEY_exit;
5164             if (strEQ(d,"eval"))                return KEY_eval;
5165             if (strEQ(d,"exec"))                return -KEY_exec;
5166             if (strEQ(d,"each"))                return KEY_each;
5167             break;
5168         case 5:
5169             if (strEQ(d,"elsif"))               return KEY_elsif;
5170             break;
5171         case 6:
5172             if (strEQ(d,"exists"))              return KEY_exists;
5173             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5174             break;
5175         case 8:
5176             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5177             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5178             break;
5179         case 9:
5180             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5181             break;
5182         case 10:
5183             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5184             if (strEQ(d,"endservent"))          return -KEY_endservent;
5185             break;
5186         case 11:
5187             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5188             break;
5189         }
5190         break;
5191     case 'f':
5192         switch (len) {
5193         case 3:
5194             if (strEQ(d,"for"))                 return KEY_for;
5195             break;
5196         case 4:
5197             if (strEQ(d,"fork"))                return -KEY_fork;
5198             break;
5199         case 5:
5200             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5201             if (strEQ(d,"flock"))               return -KEY_flock;
5202             break;
5203         case 6:
5204             if (strEQ(d,"format"))              return KEY_format;
5205             if (strEQ(d,"fileno"))              return -KEY_fileno;
5206             break;
5207         case 7:
5208             if (strEQ(d,"foreach"))             return KEY_foreach;
5209             break;
5210         case 8:
5211             if (strEQ(d,"formline"))            return -KEY_formline;
5212             break;
5213         }
5214         break;
5215     case 'G':
5216         if (len == 2) {
5217             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
5218             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
5219         }
5220         break;
5221     case 'g':
5222         if (strnEQ(d,"get",3)) {
5223             d += 3;
5224             if (*d == 'p') {
5225                 switch (len) {
5226                 case 7:
5227                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5228                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5229                     break;
5230                 case 8:
5231                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5232                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5233                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5234                     break;
5235                 case 11:
5236                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5237                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5238                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5239                     break;
5240                 case 14:
5241                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5242                     break;
5243                 case 16:
5244                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5245                     break;
5246                 }
5247             }
5248             else if (*d == 'h') {
5249                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5250                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5251                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5252             }
5253             else if (*d == 'n') {
5254                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5255                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5256                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5257             }
5258             else if (*d == 's') {
5259                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5260                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5261                 if (strEQ(d,"servent"))         return -KEY_getservent;
5262                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5263                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5264             }
5265             else if (*d == 'g') {
5266                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5267                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5268                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5269             }
5270             else if (*d == 'l') {
5271                 if (strEQ(d,"login"))           return -KEY_getlogin;
5272             }
5273             else if (strEQ(d,"c"))              return -KEY_getc;
5274             break;
5275         }
5276         switch (len) {
5277         case 2:
5278             if (strEQ(d,"gt"))                  return -KEY_gt;
5279             if (strEQ(d,"ge"))                  return -KEY_ge;
5280             break;
5281         case 4:
5282             if (strEQ(d,"grep"))                return KEY_grep;
5283             if (strEQ(d,"goto"))                return KEY_goto;
5284             if (strEQ(d,"glob"))                return KEY_glob;
5285             break;
5286         case 6:
5287             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5288             break;
5289         }
5290         break;
5291     case 'h':
5292         if (strEQ(d,"hex"))                     return -KEY_hex;
5293         break;
5294     case 'I':
5295         if (strEQ(d,"INIT"))                    return KEY_INIT;
5296         break;
5297     case 'i':
5298         switch (len) {
5299         case 2:
5300             if (strEQ(d,"if"))                  return KEY_if;
5301             break;
5302         case 3:
5303             if (strEQ(d,"int"))                 return -KEY_int;
5304             break;
5305         case 5:
5306             if (strEQ(d,"index"))               return -KEY_index;
5307             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5308             break;
5309         }
5310         break;
5311     case 'j':
5312         if (strEQ(d,"join"))                    return -KEY_join;
5313         break;
5314     case 'k':
5315         if (len == 4) {
5316             if (strEQ(d,"keys"))                return KEY_keys;
5317             if (strEQ(d,"kill"))                return -KEY_kill;
5318         }
5319         break;
5320     case 'L':
5321         if (len == 2) {
5322             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
5323             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
5324         }
5325         break;
5326     case 'l':
5327         switch (len) {
5328         case 2:
5329             if (strEQ(d,"lt"))                  return -KEY_lt;
5330             if (strEQ(d,"le"))                  return -KEY_le;
5331             if (strEQ(d,"lc"))                  return -KEY_lc;
5332             break;
5333         case 3:
5334             if (strEQ(d,"log"))                 return -KEY_log;
5335             break;
5336         case 4:
5337             if (strEQ(d,"last"))                return KEY_last;
5338             if (strEQ(d,"link"))                return -KEY_link;
5339             if (strEQ(d,"lock"))                return -KEY_lock;
5340             break;
5341         case 5:
5342             if (strEQ(d,"local"))               return KEY_local;
5343             if (strEQ(d,"lstat"))               return -KEY_lstat;
5344             break;
5345         case 6:
5346             if (strEQ(d,"length"))              return -KEY_length;
5347             if (strEQ(d,"listen"))              return -KEY_listen;
5348             break;
5349         case 7:
5350             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5351             break;
5352         case 9:
5353             if (strEQ(d,"localtime"))           return -KEY_localtime;
5354             break;
5355         }
5356         break;
5357     case 'm':
5358         switch (len) {
5359         case 1:                                 return KEY_m;
5360         case 2:
5361             if (strEQ(d,"my"))                  return KEY_my;
5362             break;
5363         case 3:
5364             if (strEQ(d,"map"))                 return KEY_map;
5365             break;
5366         case 5:
5367             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5368             break;
5369         case 6:
5370             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5371             if (strEQ(d,"msgget"))              return -KEY_msgget;
5372             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5373             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5374             break;
5375         }
5376         break;
5377     case 'N':
5378         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
5379         break;
5380     case 'n':
5381         if (strEQ(d,"next"))                    return KEY_next;
5382         if (strEQ(d,"ne"))                      return -KEY_ne;
5383         if (strEQ(d,"not"))                     return -KEY_not;
5384         if (strEQ(d,"no"))                      return KEY_no;
5385         break;
5386     case 'o':
5387         switch (len) {
5388         case 2:
5389             if (strEQ(d,"or"))                  return -KEY_or;
5390             break;
5391         case 3:
5392             if (strEQ(d,"ord"))                 return -KEY_ord;
5393             if (strEQ(d,"oct"))                 return -KEY_oct;
5394             if (strEQ(d,"our"))                 return KEY_our;
5395             break;
5396         case 4:
5397             if (strEQ(d,"open"))                return -KEY_open;
5398             break;
5399         case 7:
5400             if (strEQ(d,"opendir"))             return -KEY_opendir;
5401             break;
5402         }
5403         break;
5404     case 'p':
5405         switch (len) {
5406         case 3:
5407             if (strEQ(d,"pop"))                 return KEY_pop;
5408             if (strEQ(d,"pos"))                 return KEY_pos;
5409             break;
5410         case 4:
5411             if (strEQ(d,"push"))                return KEY_push;
5412             if (strEQ(d,"pack"))                return -KEY_pack;
5413             if (strEQ(d,"pipe"))                return -KEY_pipe;
5414             break;
5415         case 5:
5416             if (strEQ(d,"print"))               return KEY_print;
5417             break;
5418         case 6:
5419             if (strEQ(d,"printf"))              return KEY_printf;
5420             break;
5421         case 7:
5422             if (strEQ(d,"package"))             return KEY_package;
5423             break;
5424         case 9:
5425             if (strEQ(d,"prototype"))           return KEY_prototype;
5426         }
5427         break;
5428     case 'q':
5429         if (len <= 2) {
5430             if (strEQ(d,"q"))                   return KEY_q;
5431             if (strEQ(d,"qr"))                  return KEY_qr;
5432             if (strEQ(d,"qq"))                  return KEY_qq;
5433             if (strEQ(d,"qw"))                  return KEY_qw;
5434             if (strEQ(d,"qx"))                  return KEY_qx;
5435         }
5436         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5437         break;
5438     case 'r':
5439         switch (len) {
5440         case 3:
5441             if (strEQ(d,"ref"))                 return -KEY_ref;
5442             break;
5443         case 4:
5444             if (strEQ(d,"read"))                return -KEY_read;
5445             if (strEQ(d,"rand"))                return -KEY_rand;
5446             if (strEQ(d,"recv"))                return -KEY_recv;
5447             if (strEQ(d,"redo"))                return KEY_redo;
5448             break;
5449         case 5:
5450             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5451             if (strEQ(d,"reset"))               return -KEY_reset;
5452             break;
5453         case 6:
5454             if (strEQ(d,"return"))              return KEY_return;
5455             if (strEQ(d,"rename"))              return -KEY_rename;
5456             if (strEQ(d,"rindex"))              return -KEY_rindex;
5457             break;
5458         case 7:
5459             if (strEQ(d,"require"))             return -KEY_require;
5460             if (strEQ(d,"reverse"))             return -KEY_reverse;
5461             if (strEQ(d,"readdir"))             return -KEY_readdir;
5462             break;
5463         case 8:
5464             if (strEQ(d,"readlink"))            return -KEY_readlink;
5465             if (strEQ(d,"readline"))            return -KEY_readline;
5466             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5467             break;
5468         case 9:
5469             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5470             break;
5471         }
5472         break;
5473     case 's':
5474         switch (d[1]) {
5475         case 0:                                 return KEY_s;
5476         case 'c':
5477             if (strEQ(d,"scalar"))              return KEY_scalar;
5478             break;
5479         case 'e':
5480             switch (len) {
5481             case 4:
5482                 if (strEQ(d,"seek"))            return -KEY_seek;
5483                 if (strEQ(d,"send"))            return -KEY_send;
5484                 break;
5485             case 5:
5486                 if (strEQ(d,"semop"))           return -KEY_semop;
5487                 break;
5488             case 6:
5489                 if (strEQ(d,"select"))          return -KEY_select;
5490                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5491                 if (strEQ(d,"semget"))          return -KEY_semget;
5492                 break;
5493             case 7:
5494                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5495                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5496                 break;
5497             case 8:
5498                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5499                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5500                 break;
5501             case 9:
5502                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5503                 break;
5504             case 10:
5505                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5506                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5507                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5508                 break;
5509             case 11:
5510                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5511                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5512                 break;
5513             }
5514             break;
5515         case 'h':
5516             switch (len) {
5517             case 5:
5518                 if (strEQ(d,"shift"))           return KEY_shift;
5519                 break;
5520             case 6:
5521                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5522                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5523                 break;
5524             case 7:
5525                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5526                 break;
5527             case 8:
5528                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5529                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5530                 break;
5531             }
5532             break;
5533         case 'i':
5534             if (strEQ(d,"sin"))                 return -KEY_sin;
5535             break;
5536         case 'l':
5537             if (strEQ(d,"sleep"))               return -KEY_sleep;
5538             break;
5539         case 'o':
5540             if (strEQ(d,"sort"))                return KEY_sort;
5541             if (strEQ(d,"socket"))              return -KEY_socket;
5542             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5543             break;
5544         case 'p':
5545             if (strEQ(d,"split"))               return KEY_split;
5546             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5547             if (strEQ(d,"splice"))              return KEY_splice;
5548             break;
5549         case 'q':
5550             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5551             break;
5552         case 'r':
5553             if (strEQ(d,"srand"))               return -KEY_srand;
5554             break;
5555         case 't':
5556             if (strEQ(d,"stat"))                return -KEY_stat;
5557             if (strEQ(d,"study"))               return KEY_study;
5558             break;
5559         case 'u':
5560             if (strEQ(d,"substr"))              return -KEY_substr;
5561             if (strEQ(d,"sub"))                 return KEY_sub;
5562             break;
5563         case 'y':
5564             switch (len) {
5565             case 6:
5566                 if (strEQ(d,"system"))          return -KEY_system;
5567                 break;
5568             case 7:
5569                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5570                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5571                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5572                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5573                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5574                 break;
5575             case 8:
5576                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5577                 break;
5578             }
5579             break;
5580         }
5581         break;
5582     case 't':
5583         switch (len) {
5584         case 2:
5585             if (strEQ(d,"tr"))                  return KEY_tr;
5586             break;
5587         case 3:
5588             if (strEQ(d,"tie"))                 return KEY_tie;
5589             break;
5590         case 4:
5591             if (strEQ(d,"tell"))                return -KEY_tell;
5592             if (strEQ(d,"tied"))                return KEY_tied;
5593             if (strEQ(d,"time"))                return -KEY_time;
5594             break;
5595         case 5:
5596             if (strEQ(d,"times"))               return -KEY_times;
5597             break;
5598         case 7:
5599             if (strEQ(d,"telldir"))             return -KEY_telldir;
5600             break;
5601         case 8:
5602             if (strEQ(d,"truncate"))            return -KEY_truncate;
5603             break;
5604         }
5605         break;
5606     case 'u':
5607         switch (len) {
5608         case 2:
5609             if (strEQ(d,"uc"))                  return -KEY_uc;
5610             break;
5611         case 3:
5612             if (strEQ(d,"use"))                 return KEY_use;
5613             break;
5614         case 5:
5615             if (strEQ(d,"undef"))               return KEY_undef;
5616             if (strEQ(d,"until"))               return KEY_until;
5617             if (strEQ(d,"untie"))               return KEY_untie;
5618             if (strEQ(d,"utime"))               return -KEY_utime;
5619             if (strEQ(d,"umask"))               return -KEY_umask;
5620             break;
5621         case 6:
5622             if (strEQ(d,"unless"))              return KEY_unless;
5623             if (strEQ(d,"unpack"))              return -KEY_unpack;
5624             if (strEQ(d,"unlink"))              return -KEY_unlink;
5625             break;
5626         case 7:
5627             if (strEQ(d,"unshift"))             return KEY_unshift;
5628             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5629             break;
5630         }
5631         break;
5632     case 'v':
5633         if (strEQ(d,"values"))                  return -KEY_values;
5634         if (strEQ(d,"vec"))                     return -KEY_vec;
5635         break;
5636     case 'w':
5637         switch (len) {
5638         case 4:
5639             if (strEQ(d,"warn"))                return -KEY_warn;
5640             if (strEQ(d,"wait"))                return -KEY_wait;
5641             break;
5642         case 5:
5643             if (strEQ(d,"while"))               return KEY_while;
5644             if (strEQ(d,"write"))               return -KEY_write;
5645             break;
5646         case 7:
5647             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5648             break;
5649         case 9:
5650             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5651             break;
5652         }
5653         break;
5654     case 'x':
5655         if (len == 1)                           return -KEY_x;
5656         if (strEQ(d,"xor"))                     return -KEY_xor;
5657         break;
5658     case 'y':
5659         if (len == 1)                           return KEY_y;
5660         break;
5661     case 'z':
5662         break;
5663     }
5664     return 0;
5665 }
5666
5667 STATIC void
5668 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5669 {
5670     char *w;
5671
5672     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5673         dTHR;                           /* only for ckWARN */
5674         if (ckWARN(WARN_SYNTAX)) {
5675             int level = 1;
5676             for (w = s+2; *w && level; w++) {
5677                 if (*w == '(')
5678                     ++level;
5679                 else if (*w == ')')
5680                     --level;
5681             }
5682             if (*w)
5683                 for (; *w && isSPACE(*w); w++) ;
5684             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5685                 Perl_warner(aTHX_ WARN_SYNTAX,
5686                             "%s (...) interpreted as function",name);
5687         }
5688     }
5689     while (s < PL_bufend && isSPACE(*s))
5690         s++;
5691     if (*s == '(')
5692         s++;
5693     while (s < PL_bufend && isSPACE(*s))
5694         s++;
5695     if (isIDFIRST_lazy_if(s,UTF)) {
5696         w = s++;
5697         while (isALNUM_lazy_if(s,UTF))
5698             s++;
5699         while (s < PL_bufend && isSPACE(*s))
5700             s++;
5701         if (*s == ',') {
5702             int kw;
5703             *s = '\0';
5704             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5705             *s = ',';
5706             if (kw)
5707                 return;
5708             Perl_croak(aTHX_ "No comma allowed after %s", what);
5709         }
5710     }
5711 }
5712
5713 /* Either returns sv, or mortalizes sv and returns a new SV*.
5714    Best used as sv=new_constant(..., sv, ...).
5715    If s, pv are NULL, calls subroutine with one argument,
5716    and type is used with error messages only. */
5717
5718 STATIC SV *
5719 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5720                const char *type)
5721 {
5722     dSP;
5723     HV *table = GvHV(PL_hintgv);                 /* ^H */
5724     SV *res;
5725     SV **cvp;
5726     SV *cv, *typesv;
5727     const char *why1, *why2, *why3;
5728
5729     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5730         SV *msg;
5731
5732         why1 = "%^H is not consistent";
5733         why2 = strEQ(key,"charnames")
5734                ? " (missing \"use charnames ...\"?)"
5735                : "";
5736         why3 = "";
5737     report:
5738         msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5739                             (type ? type: "undef"), why1, why2, why3);
5740         yyerror(SvPVX(msg));
5741         SvREFCNT_dec(msg);
5742         return sv;
5743     }
5744     cvp = hv_fetch(table, key, strlen(key), FALSE);
5745     if (!cvp || !SvOK(*cvp)) {
5746         why1 = "$^H{";
5747         why2 = key;
5748         why3 = "} is not defined";
5749         goto report;
5750     }
5751     sv_2mortal(sv);                     /* Parent created it permanently */
5752     cv = *cvp;
5753     if (!pv && s)
5754         pv = sv_2mortal(newSVpvn(s, len));
5755     if (type && pv)
5756         typesv = sv_2mortal(newSVpv(type, 0));
5757     else
5758         typesv = &PL_sv_undef;
5759
5760     PUSHSTACKi(PERLSI_OVERLOAD);
5761     ENTER ;
5762     SAVETMPS;
5763
5764     PUSHMARK(SP) ;
5765     EXTEND(sp, 4);
5766     if (pv)
5767         PUSHs(pv);
5768     PUSHs(sv);
5769     if (pv)
5770         PUSHs(typesv);
5771     PUSHs(cv);
5772     PUTBACK;
5773     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5774
5775     SPAGAIN ;
5776
5777     /* Check the eval first */
5778     if (!PL_in_eval && SvTRUE(ERRSV)) {
5779         STRLEN n_a;
5780         sv_catpv(ERRSV, "Propagated");
5781         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5782         (void)POPs;
5783         res = SvREFCNT_inc(sv);
5784     }
5785     else {
5786         res = POPs;
5787         (void)SvREFCNT_inc(res);
5788     }
5789
5790     PUTBACK ;
5791     FREETMPS ;
5792     LEAVE ;
5793     POPSTACK;
5794
5795     if (!SvOK(res)) {
5796         why1 = "Call to &{$^H{";
5797         why2 = key;
5798         why3 = "}} did not return a defined value";
5799         sv = res;
5800         goto report;
5801     }
5802
5803     return res;
5804 }
5805
5806 STATIC char *
5807 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5808 {
5809     register char *d = dest;
5810     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5811     for (;;) {
5812         if (d >= e)
5813             Perl_croak(aTHX_ ident_too_long);
5814         if (isALNUM(*s))        /* UTF handled below */
5815             *d++ = *s++;
5816         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5817             *d++ = ':';
5818             *d++ = ':';
5819             s++;
5820         }
5821         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5822             *d++ = *s++;
5823             *d++ = *s++;
5824         }
5825         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5826             char *t = s + UTF8SKIP(s);
5827             while (*t & 0x80 && is_utf8_mark((U8*)t))
5828                 t += UTF8SKIP(t);
5829             if (d + (t - s) > e)
5830                 Perl_croak(aTHX_ ident_too_long);
5831             Copy(s, d, t - s, char);
5832             d += t - s;
5833             s = t;
5834         }
5835         else {
5836             *d = '\0';
5837             *slp = d - dest;
5838             return s;
5839         }
5840     }
5841 }
5842
5843 STATIC char *
5844 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5845 {
5846     register char *d;
5847     register char *e;
5848     char *bracket = 0;
5849     char funny = *s++;
5850
5851     if (isSPACE(*s))
5852         s = skipspace(s);
5853     d = dest;
5854     e = d + destlen - 3;        /* two-character token, ending NUL */
5855     if (isDIGIT(*s)) {
5856         while (isDIGIT(*s)) {
5857             if (d >= e)
5858                 Perl_croak(aTHX_ ident_too_long);
5859             *d++ = *s++;
5860         }
5861     }
5862     else {
5863         for (;;) {
5864             if (d >= e)
5865                 Perl_croak(aTHX_ ident_too_long);
5866             if (isALNUM(*s))    /* UTF handled below */
5867                 *d++ = *s++;
5868             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5869                 *d++ = ':';
5870                 *d++ = ':';
5871                 s++;
5872             }
5873             else if (*s == ':' && s[1] == ':') {
5874                 *d++ = *s++;
5875                 *d++ = *s++;
5876             }
5877             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5878                 char *t = s + UTF8SKIP(s);
5879                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5880                     t += UTF8SKIP(t);
5881                 if (d + (t - s) > e)
5882                     Perl_croak(aTHX_ ident_too_long);
5883                 Copy(s, d, t - s, char);
5884                 d += t - s;
5885                 s = t;
5886             }
5887             else
5888                 break;
5889         }
5890     }
5891     *d = '\0';
5892     d = dest;
5893     if (*d) {
5894         if (PL_lex_state != LEX_NORMAL)
5895             PL_lex_state = LEX_INTERPENDMAYBE;
5896         return s;
5897     }
5898     if (*s == '$' && s[1] &&
5899         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5900     {
5901         return s;
5902     }
5903     if (*s == '{') {
5904         bracket = s;
5905         s++;
5906     }
5907     else if (ck_uni)
5908         check_uni();
5909     if (s < send)
5910         *d = *s++;
5911     d[1] = '\0';
5912     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5913         *d = toCTRL(*s);
5914         s++;
5915     }
5916     if (bracket) {
5917         if (isSPACE(s[-1])) {
5918             while (s < send) {
5919                 char ch = *s++;
5920                 if (!SPACE_OR_TAB(ch)) {
5921                     *d = ch;
5922                     break;
5923                 }
5924             }
5925         }
5926         if (isIDFIRST_lazy_if(d,UTF)) {
5927             d++;
5928             if (UTF) {
5929                 e = s;
5930                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
5931                     e += UTF8SKIP(e);
5932                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5933                         e += UTF8SKIP(e);
5934                 }
5935                 Copy(s, d, e - s, char);
5936                 d += e - s;
5937                 s = e;
5938             }
5939             else {
5940                 while ((isALNUM(*s) || *s == ':') && d < e)
5941                     *d++ = *s++;
5942                 if (d >= e)
5943                     Perl_croak(aTHX_ ident_too_long);
5944             }
5945             *d = '\0';
5946             while (s < send && SPACE_OR_TAB(*s)) s++;
5947             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5948                 dTHR;                   /* only for ckWARN */
5949                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5950                     const char *brack = *s == '[' ? "[...]" : "{...}";
5951                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5952                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5953                         funny, dest, brack, funny, dest, brack);
5954                 }
5955                 bracket++;
5956                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5957                 return s;
5958             }
5959         }
5960         /* Handle extended ${^Foo} variables
5961          * 1999-02-27 mjd-perl-patch@plover.com */
5962         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5963                  && isALNUM(*s))
5964         {
5965             d++;
5966             while (isALNUM(*s) && d < e) {
5967                 *d++ = *s++;
5968             }
5969             if (d >= e)
5970                 Perl_croak(aTHX_ ident_too_long);
5971             *d = '\0';
5972         }
5973         if (*s == '}') {
5974             s++;
5975             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5976                 PL_lex_state = LEX_INTERPEND;
5977             if (funny == '#')
5978                 funny = '@';
5979             if (PL_lex_state == LEX_NORMAL) {
5980                 dTHR;                   /* only for ckWARN */
5981                 if (ckWARN(WARN_AMBIGUOUS) &&
5982                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5983                 {
5984                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5985                         "Ambiguous use of %c{%s} resolved to %c%s",
5986                         funny, dest, funny, dest);
5987                 }
5988             }
5989         }
5990         else {
5991             s = bracket;                /* let the parser handle it */
5992             *dest = '\0';
5993         }
5994     }
5995     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5996         PL_lex_state = LEX_INTERPEND;
5997     return s;
5998 }
5999
6000 void
6001 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6002 {
6003     if (ch == 'i')
6004         *pmfl |= PMf_FOLD;
6005     else if (ch == 'g')
6006         *pmfl |= PMf_GLOBAL;
6007     else if (ch == 'c')
6008         *pmfl |= PMf_CONTINUE;
6009     else if (ch == 'o')
6010         *pmfl |= PMf_KEEP;
6011     else if (ch == 'm')
6012         *pmfl |= PMf_MULTILINE;
6013     else if (ch == 's')
6014         *pmfl |= PMf_SINGLELINE;
6015     else if (ch == 'x')
6016         *pmfl |= PMf_EXTENDED;
6017 }
6018
6019 STATIC char *
6020 S_scan_pat(pTHX_ char *start, I32 type)
6021 {
6022     PMOP *pm;
6023     char *s;
6024
6025     s = scan_str(start,FALSE,FALSE);
6026     if (!s) {
6027         if (PL_lex_stuff)
6028             SvREFCNT_dec(PL_lex_stuff);
6029         PL_lex_stuff = Nullsv;
6030         Perl_croak(aTHX_ "Search pattern not terminated");
6031     }
6032
6033     pm = (PMOP*)newPMOP(type, 0);
6034     if (PL_multi_open == '?')
6035         pm->op_pmflags |= PMf_ONCE;
6036     if(type == OP_QR) {
6037         while (*s && strchr("iomsx", *s))
6038             pmflag(&pm->op_pmflags,*s++);
6039     }
6040     else {
6041         while (*s && strchr("iogcmsx", *s))
6042             pmflag(&pm->op_pmflags,*s++);
6043     }
6044     pm->op_pmpermflags = pm->op_pmflags;
6045
6046     PL_lex_op = (OP*)pm;
6047     yylval.ival = OP_MATCH;
6048     return s;
6049 }
6050
6051 STATIC char *
6052 S_scan_subst(pTHX_ char *start)
6053 {
6054     register char *s;
6055     register PMOP *pm;
6056     I32 first_start;
6057     I32 es = 0;
6058
6059     yylval.ival = OP_NULL;
6060
6061     s = scan_str(start,FALSE,FALSE);
6062
6063     if (!s) {
6064         if (PL_lex_stuff)
6065             SvREFCNT_dec(PL_lex_stuff);
6066         PL_lex_stuff = Nullsv;
6067         Perl_croak(aTHX_ "Substitution pattern not terminated");
6068     }
6069
6070     if (s[-1] == PL_multi_open)
6071         s--;
6072
6073     first_start = PL_multi_start;
6074     s = scan_str(s,FALSE,FALSE);
6075     if (!s) {
6076         if (PL_lex_stuff)
6077             SvREFCNT_dec(PL_lex_stuff);
6078         PL_lex_stuff = Nullsv;
6079         if (PL_lex_repl)
6080             SvREFCNT_dec(PL_lex_repl);
6081         PL_lex_repl = Nullsv;
6082         Perl_croak(aTHX_ "Substitution replacement not terminated");
6083     }
6084     PL_multi_start = first_start;       /* so whole substitution is taken together */
6085
6086     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6087     while (*s) {
6088         if (*s == 'e') {
6089             s++;
6090             es++;
6091         }
6092         else if (strchr("iogcmsx", *s))
6093             pmflag(&pm->op_pmflags,*s++);
6094         else
6095             break;
6096     }
6097
6098     if (es) {
6099         SV *repl;
6100         PL_sublex_info.super_bufptr = s;
6101         PL_sublex_info.super_bufend = PL_bufend;
6102         PL_multi_end = 0;
6103         pm->op_pmflags |= PMf_EVAL;
6104         repl = newSVpvn("",0);
6105         while (es-- > 0)
6106             sv_catpv(repl, es ? "eval " : "do ");
6107         sv_catpvn(repl, "{ ", 2);
6108         sv_catsv(repl, PL_lex_repl);
6109         sv_catpvn(repl, " };", 2);
6110         SvEVALED_on(repl);
6111         SvREFCNT_dec(PL_lex_repl);
6112         PL_lex_repl = repl;
6113     }
6114
6115     pm->op_pmpermflags = pm->op_pmflags;
6116     PL_lex_op = (OP*)pm;
6117     yylval.ival = OP_SUBST;
6118     return s;
6119 }
6120
6121 STATIC char *
6122 S_scan_trans(pTHX_ char *start)
6123 {
6124     register char* s;
6125     OP *o;
6126     short *tbl;
6127     I32 squash;
6128     I32 del;
6129     I32 complement;
6130     I32 utf8;
6131     I32 count = 0;
6132
6133     yylval.ival = OP_NULL;
6134
6135     s = scan_str(start,FALSE,FALSE);
6136     if (!s) {
6137         if (PL_lex_stuff)
6138             SvREFCNT_dec(PL_lex_stuff);
6139         PL_lex_stuff = Nullsv;
6140         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6141     }
6142     if (s[-1] == PL_multi_open)
6143         s--;
6144
6145     s = scan_str(s,FALSE,FALSE);
6146     if (!s) {
6147         if (PL_lex_stuff)
6148             SvREFCNT_dec(PL_lex_stuff);
6149         PL_lex_stuff = Nullsv;
6150         if (PL_lex_repl)
6151             SvREFCNT_dec(PL_lex_repl);
6152         PL_lex_repl = Nullsv;
6153         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6154     }
6155
6156     New(803,tbl,256,short);
6157     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6158
6159     complement = del = squash = 0;
6160     while (strchr("cds", *s)) {
6161         if (*s == 'c')
6162             complement = OPpTRANS_COMPLEMENT;
6163         else if (*s == 'd')
6164             del = OPpTRANS_DELETE;
6165         else if (*s == 's')
6166             squash = OPpTRANS_SQUASH;
6167         s++;
6168     }
6169     o->op_private = del|squash|complement;
6170
6171     PL_lex_op = o;
6172     yylval.ival = OP_TRANS;
6173     return s;
6174 }
6175
6176 STATIC char *
6177 S_scan_heredoc(pTHX_ register char *s)
6178 {
6179     dTHR;
6180     SV *herewas;
6181     I32 op_type = OP_SCALAR;
6182     I32 len;
6183     SV *tmpstr;
6184     char term;
6185     register char *d;
6186     register char *e;
6187     char *peek;
6188     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6189
6190     s += 2;
6191     d = PL_tokenbuf;
6192     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6193     if (!outer)
6194         *d++ = '\n';
6195     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6196     if (*peek && strchr("`'\"",*peek)) {
6197         s = peek;
6198         term = *s++;
6199         s = delimcpy(d, e, s, PL_bufend, term, &len);
6200         d += len;
6201         if (s < PL_bufend)
6202             s++;
6203     }
6204     else {
6205         if (*s == '\\')
6206             s++, term = '\'';
6207         else
6208             term = '"';
6209         if (!isALNUM_lazy_if(s,UTF))
6210             deprecate("bare << to mean <<\"\"");
6211         for (; isALNUM_lazy_if(s,UTF); s++) {
6212             if (d < e)
6213                 *d++ = *s;
6214         }
6215     }
6216     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6217         Perl_croak(aTHX_ "Delimiter for here document is too long");
6218     *d++ = '\n';
6219     *d = '\0';
6220     len = d - PL_tokenbuf;
6221 #ifndef PERL_STRICT_CR
6222     d = strchr(s, '\r');
6223     if (d) {
6224         char *olds = s;
6225         s = d;
6226         while (s < PL_bufend) {
6227             if (*s == '\r') {
6228                 *d++ = '\n';
6229                 if (*++s == '\n')
6230                     s++;
6231             }
6232             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6233                 *d++ = *s++;
6234                 s++;
6235             }
6236             else
6237                 *d++ = *s++;
6238         }
6239         *d = '\0';
6240         PL_bufend = d;
6241         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6242         s = olds;
6243     }
6244 #endif
6245     d = "\n";
6246     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6247         herewas = newSVpvn(s,PL_bufend-s);
6248     else
6249         s--, herewas = newSVpvn(s,d-s);
6250     s += SvCUR(herewas);
6251
6252     tmpstr = NEWSV(87,79);
6253     sv_upgrade(tmpstr, SVt_PVIV);
6254     if (term == '\'') {
6255         op_type = OP_CONST;
6256         SvIVX(tmpstr) = -1;
6257     }
6258     else if (term == '`') {
6259         op_type = OP_BACKTICK;
6260         SvIVX(tmpstr) = '\\';
6261     }
6262
6263     CLINE;
6264     PL_multi_start = CopLINE(PL_curcop);
6265     PL_multi_open = PL_multi_close = '<';
6266     term = *PL_tokenbuf;
6267     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6268         char *bufptr = PL_sublex_info.super_bufptr;
6269         char *bufend = PL_sublex_info.super_bufend;
6270         char *olds = s - SvCUR(herewas);
6271         s = strchr(bufptr, '\n');
6272         if (!s)
6273             s = bufend;
6274         d = s;
6275         while (s < bufend &&
6276           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6277             if (*s++ == '\n')
6278                 CopLINE_inc(PL_curcop);
6279         }
6280         if (s >= bufend) {
6281             CopLINE_set(PL_curcop, PL_multi_start);
6282             missingterm(PL_tokenbuf);
6283         }
6284         sv_setpvn(herewas,bufptr,d-bufptr+1);
6285         sv_setpvn(tmpstr,d+1,s-d);
6286         s += len - 1;
6287         sv_catpvn(herewas,s,bufend-s);
6288         (void)strcpy(bufptr,SvPVX(herewas));
6289
6290         s = olds;
6291         goto retval;
6292     }
6293     else if (!outer) {
6294         d = s;
6295         while (s < PL_bufend &&
6296           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6297             if (*s++ == '\n')
6298                 CopLINE_inc(PL_curcop);
6299         }
6300         if (s >= PL_bufend) {
6301             CopLINE_set(PL_curcop, PL_multi_start);
6302             missingterm(PL_tokenbuf);
6303         }
6304         sv_setpvn(tmpstr,d+1,s-d);
6305         s += len - 1;
6306         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6307
6308         sv_catpvn(herewas,s,PL_bufend-s);
6309         sv_setsv(PL_linestr,herewas);
6310         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6311         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6312     }
6313     else
6314         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6315     while (s >= PL_bufend) {    /* multiple line string? */
6316         if (!outer ||
6317          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6318             CopLINE_set(PL_curcop, PL_multi_start);
6319             missingterm(PL_tokenbuf);
6320         }
6321         CopLINE_inc(PL_curcop);
6322         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6323 #ifndef PERL_STRICT_CR
6324         if (PL_bufend - PL_linestart >= 2) {
6325             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6326                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6327             {
6328                 PL_bufend[-2] = '\n';
6329                 PL_bufend--;
6330                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6331             }
6332             else if (PL_bufend[-1] == '\r')
6333                 PL_bufend[-1] = '\n';
6334         }
6335         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6336             PL_bufend[-1] = '\n';
6337 #endif
6338         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6339             SV *sv = NEWSV(88,0);
6340
6341             sv_upgrade(sv, SVt_PVMG);
6342             sv_setsv(sv,PL_linestr);
6343             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6344         }
6345         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6346             s = PL_bufend - 1;
6347             *s = ' ';
6348             sv_catsv(PL_linestr,herewas);
6349             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6350         }
6351         else {
6352             s = PL_bufend;
6353             sv_catsv(tmpstr,PL_linestr);
6354         }
6355     }
6356     s++;
6357 retval:
6358     PL_multi_end = CopLINE(PL_curcop);
6359     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6360         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6361         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6362     }
6363     SvREFCNT_dec(herewas);
6364     PL_lex_stuff = tmpstr;
6365     yylval.ival = op_type;
6366     return s;
6367 }
6368
6369 /* scan_inputsymbol
6370    takes: current position in input buffer
6371    returns: new position in input buffer
6372    side-effects: yylval and lex_op are set.
6373
6374    This code handles:
6375
6376    <>           read from ARGV
6377    <FH>         read from filehandle
6378    <pkg::FH>    read from package qualified filehandle
6379    <pkg'FH>     read from package qualified filehandle
6380    <$fh>        read from filehandle in $fh
6381    <*.h>        filename glob
6382
6383 */
6384
6385 STATIC char *
6386 S_scan_inputsymbol(pTHX_ char *start)
6387 {
6388     register char *s = start;           /* current position in buffer */
6389     register char *d;
6390     register char *e;
6391     char *end;
6392     I32 len;
6393
6394     d = PL_tokenbuf;                    /* start of temp holding space */
6395     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6396     end = strchr(s, '\n');
6397     if (!end)
6398         end = PL_bufend;
6399     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6400
6401     /* die if we didn't have space for the contents of the <>,
6402        or if it didn't end, or if we see a newline
6403     */
6404
6405     if (len >= sizeof PL_tokenbuf)
6406         Perl_croak(aTHX_ "Excessively long <> operator");
6407     if (s >= end)
6408         Perl_croak(aTHX_ "Unterminated <> operator");
6409
6410     s++;
6411
6412     /* check for <$fh>
6413        Remember, only scalar variables are interpreted as filehandles by
6414        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6415        treated as a glob() call.
6416        This code makes use of the fact that except for the $ at the front,
6417        a scalar variable and a filehandle look the same.
6418     */
6419     if (*d == '$' && d[1]) d++;
6420
6421     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6422     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6423         d++;
6424
6425     /* If we've tried to read what we allow filehandles to look like, and
6426        there's still text left, then it must be a glob() and not a getline.
6427        Use scan_str to pull out the stuff between the <> and treat it
6428        as nothing more than a string.
6429     */
6430
6431     if (d - PL_tokenbuf != len) {
6432         yylval.ival = OP_GLOB;
6433         set_csh();
6434         s = scan_str(start,FALSE,FALSE);
6435         if (!s)
6436            Perl_croak(aTHX_ "Glob not terminated");
6437         return s;
6438     }
6439     else {
6440         /* we're in a filehandle read situation */
6441         d = PL_tokenbuf;
6442
6443         /* turn <> into <ARGV> */
6444         if (!len)
6445             (void)strcpy(d,"ARGV");
6446
6447         /* if <$fh>, create the ops to turn the variable into a
6448            filehandle
6449         */
6450         if (*d == '$') {
6451             I32 tmp;
6452
6453             /* try to find it in the pad for this block, otherwise find
6454                add symbol table ops
6455             */
6456             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6457                 OP *o = newOP(OP_PADSV, 0);
6458                 o->op_targ = tmp;
6459                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6460             }
6461             else {
6462                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6463                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6464                                             newUNOP(OP_RV2SV, 0,
6465                                                 newGVOP(OP_GV, 0, gv)));
6466             }
6467             PL_lex_op->op_flags |= OPf_SPECIAL;
6468             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6469             yylval.ival = OP_NULL;
6470         }
6471
6472         /* If it's none of the above, it must be a literal filehandle
6473            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6474         else {
6475             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6476             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6477             yylval.ival = OP_NULL;
6478         }
6479     }
6480
6481     return s;
6482 }
6483
6484
6485 /* scan_str
6486    takes: start position in buffer
6487           keep_quoted preserve \ on the embedded delimiter(s)
6488           keep_delims preserve the delimiters around the string
6489    returns: position to continue reading from buffer
6490    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6491         updates the read buffer.
6492
6493    This subroutine pulls a string out of the input.  It is called for:
6494         q               single quotes           q(literal text)
6495         '               single quotes           'literal text'
6496         qq              double quotes           qq(interpolate $here please)
6497         "               double quotes           "interpolate $here please"
6498         qx              backticks               qx(/bin/ls -l)
6499         `               backticks               `/bin/ls -l`
6500         qw              quote words             @EXPORT_OK = qw( func() $spam )
6501         m//             regexp match            m/this/
6502         s///            regexp substitute       s/this/that/
6503         tr///           string transliterate    tr/this/that/
6504         y///            string transliterate    y/this/that/
6505         ($*@)           sub prototypes          sub foo ($)
6506         (stuff)         sub attr parameters     sub foo : attr(stuff)
6507         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6508
6509    In most of these cases (all but <>, patterns and transliterate)
6510    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6511    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6512    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6513    calls scan_str().
6514
6515    It skips whitespace before the string starts, and treats the first
6516    character as the delimiter.  If the delimiter is one of ([{< then
6517    the corresponding "close" character )]}> is used as the closing
6518    delimiter.  It allows quoting of delimiters, and if the string has
6519    balanced delimiters ([{<>}]) it allows nesting.
6520
6521    The lexer always reads these strings into lex_stuff, except in the
6522    case of the operators which take *two* arguments (s/// and tr///)
6523    when it checks to see if lex_stuff is full (presumably with the 1st
6524    arg to s or tr) and if so puts the string into lex_repl.
6525
6526 */
6527
6528 STATIC char *
6529 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6530 {
6531     dTHR;
6532     SV *sv;                             /* scalar value: string */
6533     char *tmps;                         /* temp string, used for delimiter matching */
6534     register char *s = start;           /* current position in the buffer */
6535     register char term;                 /* terminating character */
6536     register char *to;                  /* current position in the sv's data */
6537     I32 brackets = 1;                   /* bracket nesting level */
6538     bool has_utf = FALSE;               /* is there any utf8 content? */
6539
6540     /* skip space before the delimiter */
6541     if (isSPACE(*s))
6542         s = skipspace(s);
6543
6544     /* mark where we are, in case we need to report errors */
6545     CLINE;
6546
6547     /* after skipping whitespace, the next character is the terminator */
6548     term = *s;
6549     if ((term & 0x80) && UTF)
6550         has_utf = TRUE;
6551
6552     /* mark where we are */
6553     PL_multi_start = CopLINE(PL_curcop);
6554     PL_multi_open = term;
6555
6556     /* find corresponding closing delimiter */
6557     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6558         term = tmps[5];
6559     PL_multi_close = term;
6560
6561     /* create a new SV to hold the contents.  87 is leak category, I'm
6562        assuming.  79 is the SV's initial length.  What a random number. */
6563     sv = NEWSV(87,79);
6564     sv_upgrade(sv, SVt_PVIV);
6565     SvIVX(sv) = term;
6566     (void)SvPOK_only(sv);               /* validate pointer */
6567
6568     /* move past delimiter and try to read a complete string */
6569     if (keep_delims)
6570         sv_catpvn(sv, s, 1);
6571     s++;
6572     for (;;) {
6573         /* extend sv if need be */
6574         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6575         /* set 'to' to the next character in the sv's string */
6576         to = SvPVX(sv)+SvCUR(sv);
6577
6578         /* if open delimiter is the close delimiter read unbridle */
6579         if (PL_multi_open == PL_multi_close) {
6580             for (; s < PL_bufend; s++,to++) {
6581                 /* embedded newlines increment the current line number */
6582                 if (*s == '\n' && !PL_rsfp)
6583                     CopLINE_inc(PL_curcop);
6584                 /* handle quoted delimiters */
6585                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6586                     if (!keep_quoted && s[1] == term)
6587                         s++;
6588                 /* any other quotes are simply copied straight through */
6589                     else
6590                         *to++ = *s++;
6591                 }
6592                 /* terminate when run out of buffer (the for() condition), or
6593                    have found the terminator */
6594                 else if (*s == term)
6595                     break;
6596                 else if (!has_utf && (*s & 0x80) && UTF)
6597                     has_utf = TRUE;
6598                 *to = *s;
6599             }
6600         }
6601
6602         /* if the terminator isn't the same as the start character (e.g.,
6603            matched brackets), we have to allow more in the quoting, and
6604            be prepared for nested brackets.
6605         */
6606         else {
6607             /* read until we run out of string, or we find the terminator */
6608             for (; s < PL_bufend; s++,to++) {
6609                 /* embedded newlines increment the line count */
6610                 if (*s == '\n' && !PL_rsfp)
6611                     CopLINE_inc(PL_curcop);
6612                 /* backslashes can escape the open or closing characters */
6613                 if (*s == '\\' && s+1 < PL_bufend) {
6614                     if (!keep_quoted &&
6615                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6616                         s++;
6617                     else
6618                         *to++ = *s++;
6619                 }
6620                 /* allow nested opens and closes */
6621                 else if (*s == PL_multi_close && --brackets <= 0)
6622                     break;
6623                 else if (*s == PL_multi_open)
6624                     brackets++;
6625                 else if (!has_utf && (*s & 0x80) && UTF)
6626                     has_utf = TRUE;
6627                 *to = *s;
6628             }
6629         }
6630         /* terminate the copied string and update the sv's end-of-string */
6631         *to = '\0';
6632         SvCUR_set(sv, to - SvPVX(sv));
6633
6634         /*
6635          * this next chunk reads more into the buffer if we're not done yet
6636          */
6637
6638         if (s < PL_bufend)
6639             break;              /* handle case where we are done yet :-) */
6640
6641 #ifndef PERL_STRICT_CR
6642         if (to - SvPVX(sv) >= 2) {
6643             if ((to[-2] == '\r' && to[-1] == '\n') ||
6644                 (to[-2] == '\n' && to[-1] == '\r'))
6645             {
6646                 to[-2] = '\n';
6647                 to--;
6648                 SvCUR_set(sv, to - SvPVX(sv));
6649             }
6650             else if (to[-1] == '\r')
6651                 to[-1] = '\n';
6652         }
6653         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6654             to[-1] = '\n';
6655 #endif
6656
6657         /* if we're out of file, or a read fails, bail and reset the current
6658            line marker so we can report where the unterminated string began
6659         */
6660         if (!PL_rsfp ||
6661          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6662             sv_free(sv);
6663             CopLINE_set(PL_curcop, PL_multi_start);
6664             return Nullch;
6665         }
6666         /* we read a line, so increment our line counter */
6667         CopLINE_inc(PL_curcop);
6668
6669         /* update debugger info */
6670         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6671             SV *sv = NEWSV(88,0);
6672
6673             sv_upgrade(sv, SVt_PVMG);
6674             sv_setsv(sv,PL_linestr);
6675             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6676         }
6677
6678         /* having changed the buffer, we must update PL_bufend */
6679         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6680     }
6681
6682     /* at this point, we have successfully read the delimited string */
6683
6684     if (keep_delims)
6685         sv_catpvn(sv, s, 1);
6686     if (has_utf)
6687         SvUTF8_on(sv);
6688     PL_multi_end = CopLINE(PL_curcop);
6689     s++;
6690
6691     /* if we allocated too much space, give some back */
6692     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6693         SvLEN_set(sv, SvCUR(sv) + 1);
6694         Renew(SvPVX(sv), SvLEN(sv), char);
6695     }
6696
6697     /* decide whether this is the first or second quoted string we've read
6698        for this op
6699     */
6700
6701     if (PL_lex_stuff)
6702         PL_lex_repl = sv;
6703     else
6704         PL_lex_stuff = sv;
6705     return s;
6706 }
6707
6708 /*
6709   scan_num
6710   takes: pointer to position in buffer
6711   returns: pointer to new position in buffer
6712   side-effects: builds ops for the constant in yylval.op
6713
6714   Read a number in any of the formats that Perl accepts:
6715
6716   0(x[0-7A-F]+)|([0-7]+)|(b[01])
6717   [\d_]+(\.[\d_]*)?[Ee](\d+)
6718
6719   Underbars (_) are allowed in decimal numbers.  If -w is on,
6720   underbars before a decimal point must be at three digit intervals.
6721
6722   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6723   thing it reads.
6724
6725   If it reads a number without a decimal point or an exponent, it will
6726   try converting the number to an integer and see if it can do so
6727   without loss of precision.
6728 */
6729
6730 char *
6731 Perl_scan_num(pTHX_ char *start)
6732 {
6733     register char *s = start;           /* current position in buffer */
6734     register char *d;                   /* destination in temp buffer */
6735     register char *e;                   /* end of temp buffer */
6736     NV nv;                              /* number read, as a double */
6737     SV *sv = Nullsv;                    /* place to put the converted number */
6738     bool floatit;                       /* boolean: int or float? */
6739     char *lastub = 0;                   /* position of last underbar */
6740     static char number_too_long[] = "Number too long";
6741
6742     /* We use the first character to decide what type of number this is */
6743
6744     switch (*s) {
6745     default:
6746       Perl_croak(aTHX_ "panic: scan_num");
6747
6748     /* if it starts with a 0, it could be an octal number, a decimal in
6749        0.13 disguise, or a hexadecimal number, or a binary number. */
6750     case '0':
6751         {
6752           /* variables:
6753              u          holds the "number so far"
6754              shift      the power of 2 of the base
6755                         (hex == 4, octal == 3, binary == 1)
6756              overflowed was the number more than we can hold?
6757
6758              Shift is used when we add a digit.  It also serves as an "are
6759              we in octal/hex/binary?" indicator to disallow hex characters
6760              when in octal mode.
6761            */
6762             dTHR;
6763             NV n = 0.0;
6764             UV u = 0;
6765             I32 shift;
6766             bool overflowed = FALSE;
6767             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6768             static char* bases[5] = { "", "binary", "", "octal",
6769                                       "hexadecimal" };
6770             static char* Bases[5] = { "", "Binary", "", "Octal",
6771                                       "Hexadecimal" };
6772             static char *maxima[5] = { "",
6773                                        "0b11111111111111111111111111111111",
6774                                        "",
6775                                        "037777777777",
6776                                        "0xffffffff" };
6777             char *base, *Base, *max;
6778
6779             /* check for hex */
6780             if (s[1] == 'x') {
6781                 shift = 4;
6782                 s += 2;
6783             } else if (s[1] == 'b') {
6784                 shift = 1;
6785                 s += 2;
6786             }
6787             /* check for a decimal in disguise */
6788             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6789                 goto decimal;
6790             /* so it must be octal */
6791             else
6792                 shift = 3;
6793
6794             base = bases[shift];
6795             Base = Bases[shift];
6796             max  = maxima[shift];
6797
6798             /* read the rest of the number */
6799             for (;;) {
6800                 /* x is used in the overflow test,
6801                    b is the digit we're adding on. */
6802                 UV x, b;
6803
6804                 switch (*s) {
6805
6806                 /* if we don't mention it, we're done */
6807                 default:
6808                     goto out;
6809
6810                 /* _ are ignored */
6811                 case '_':
6812                     s++;
6813                     break;
6814
6815                 /* 8 and 9 are not octal */
6816                 case '8': case '9':
6817                     if (shift == 3)
6818                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6819                     /* FALL THROUGH */
6820
6821                 /* octal digits */
6822                 case '2': case '3': case '4':
6823                 case '5': case '6': case '7':
6824                     if (shift == 1)
6825                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6826                     /* FALL THROUGH */
6827
6828                 case '0': case '1':
6829                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6830                     goto digit;
6831
6832                 /* hex digits */
6833                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6834                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6835                     /* make sure they said 0x */
6836                     if (shift != 4)
6837                         goto out;
6838                     b = (*s++ & 7) + 9;
6839
6840                     /* Prepare to put the digit we have onto the end
6841                        of the number so far.  We check for overflows.
6842                     */
6843
6844                   digit:
6845                     if (!overflowed) {
6846                         x = u << shift; /* make room for the digit */
6847
6848                         if ((x >> shift) != u
6849                             && !(PL_hints & HINT_NEW_BINARY)) {
6850                             dTHR;
6851                             overflowed = TRUE;
6852                             n = (NV) u;
6853                             if (ckWARN_d(WARN_OVERFLOW))
6854                                 Perl_warner(aTHX_ WARN_OVERFLOW,
6855                                             "Integer overflow in %s number",
6856                                             base);
6857                         } else
6858                             u = x | b;          /* add the digit to the end */
6859                     }
6860                     if (overflowed) {
6861                         n *= nvshift[shift];
6862                         /* If an NV has not enough bits in its
6863                          * mantissa to represent an UV this summing of
6864                          * small low-order numbers is a waste of time
6865                          * (because the NV cannot preserve the
6866                          * low-order bits anyway): we could just
6867                          * remember when did we overflow and in the
6868                          * end just multiply n by the right
6869                          * amount. */
6870                         n += (NV) b;
6871                     }
6872                     break;
6873                 }
6874             }
6875
6876           /* if we get here, we had success: make a scalar value from
6877              the number.
6878           */
6879           out:
6880             sv = NEWSV(92,0);
6881             if (overflowed) {
6882                 dTHR;
6883                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6884                     Perl_warner(aTHX_ WARN_PORTABLE,
6885                                 "%s number > %s non-portable",
6886                                 Base, max);
6887                 sv_setnv(sv, n);
6888             }
6889             else {
6890 #if UVSIZE > 4
6891                 dTHR;
6892                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6893                     Perl_warner(aTHX_ WARN_PORTABLE,
6894                                 "%s number > %s non-portable",
6895                                 Base, max);
6896 #endif
6897                 sv_setuv(sv, u);
6898             }
6899             if (PL_hints & HINT_NEW_BINARY)
6900                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6901         }
6902         break;
6903
6904     /*
6905       handle decimal numbers.
6906       we're also sent here when we read a 0 as the first digit
6907     */
6908     case '1': case '2': case '3': case '4': case '5':
6909     case '6': case '7': case '8': case '9': case '.':
6910       decimal:
6911         d = PL_tokenbuf;
6912         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6913         floatit = FALSE;
6914
6915         /* read next group of digits and _ and copy into d */
6916         while (isDIGIT(*s) || *s == '_') {
6917             /* skip underscores, checking for misplaced ones
6918                if -w is on
6919             */
6920             if (*s == '_') {
6921                 dTHR;                   /* only for ckWARN */
6922                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6923                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6924                 lastub = ++s;
6925             }
6926             else {
6927                 /* check for end of fixed-length buffer */
6928                 if (d >= e)
6929                     Perl_croak(aTHX_ number_too_long);
6930                 /* if we're ok, copy the character */
6931                 *d++ = *s++;
6932             }
6933         }
6934
6935         /* final misplaced underbar check */
6936         if (lastub && s - lastub != 3) {
6937             dTHR;
6938             if (ckWARN(WARN_SYNTAX))
6939                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6940         }
6941
6942         /* read a decimal portion if there is one.  avoid
6943            3..5 being interpreted as the number 3. followed
6944            by .5
6945         */
6946         if (*s == '.' && s[1] != '.') {
6947             floatit = TRUE;
6948             *d++ = *s++;
6949
6950             /* copy, ignoring underbars, until we run out of
6951                digits.  Note: no misplaced underbar checks!
6952             */
6953             for (; isDIGIT(*s) || *s == '_'; s++) {
6954                 /* fixed length buffer check */
6955                 if (d >= e)
6956                     Perl_croak(aTHX_ number_too_long);
6957                 if (*s != '_')
6958                     *d++ = *s;
6959             }
6960             if (*s == '.' && isDIGIT(s[1])) {
6961                 /* oops, it's really a v-string, but without the "v" */
6962                 s = start - 1;
6963                 goto vstring;
6964             }
6965         }
6966
6967         /* read exponent part, if present */
6968         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6969             floatit = TRUE;
6970             s++;
6971
6972             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6973             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6974
6975             /* allow positive or negative exponent */
6976             if (*s == '+' || *s == '-')
6977                 *d++ = *s++;
6978
6979             /* read digits of exponent (no underbars :-) */
6980             while (isDIGIT(*s)) {
6981                 if (d >= e)
6982                     Perl_croak(aTHX_ number_too_long);
6983                 *d++ = *s++;
6984             }
6985         }
6986
6987         /* terminate the string */
6988         *d = '\0';
6989
6990         /* make an sv from the string */
6991         sv = NEWSV(92,0);
6992
6993 #if defined(Strtol) && defined(Strtoul)
6994
6995         /*
6996            strtol/strtoll sets errno to ERANGE if the number is too big
6997            for an integer. We try to do an integer conversion first
6998            if no characters indicating "float" have been found.
6999          */
7000
7001         if (!floatit) {
7002             IV iv;
7003             UV uv;
7004             errno = 0;
7005             if (*PL_tokenbuf == '-')
7006                 iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
7007             else
7008                 uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
7009             if (errno)
7010                 floatit = TRUE; /* Probably just too large. */
7011             else if (*PL_tokenbuf == '-')
7012                 sv_setiv(sv, iv);
7013             else if (uv <= IV_MAX)
7014                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7015             else
7016                 sv_setuv(sv, uv);
7017         }
7018         if (floatit) {
7019             nv = Atof(PL_tokenbuf);
7020             sv_setnv(sv, nv);
7021         }
7022 #else
7023         /*
7024            No working strtou?ll?.
7025
7026            Unfortunately atol() doesn't do range checks (returning
7027            LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows)
7028            everywhere [1], so we cannot use use atol() (or atoll()).
7029            If we could, they would be used, as Atol(), very much like
7030            Strtol() and Strtoul() are used above.
7031
7032            [1] XXX Configure test needed to check for atol()
7033                    (and atoll()) overflow behaviour XXX
7034
7035            --jhi
7036
7037            We need to do this the hard way.  */
7038
7039         nv = Atof(PL_tokenbuf);
7040
7041         /* See if we can make do with an integer value without loss of
7042            precision.  We use U_V to cast to a UV, because some
7043            compilers have issues.  Then we try casting it back and see
7044            if it was the same [1].  We only do this if we know we
7045            specifically read an integer.  If floatit is true, then we
7046            don't need to do the conversion at all.
7047
7048            [1] Note that this is lossy if our NVs cannot preserve our
7049            UVs.  There are metaconfig defines NV_PRESERVES_UV (a boolean)
7050            and NV_PRESERVES_UV_BITS (a number), but in general we really
7051            do hope all such potentially lossy platforms have strtou?ll?
7052            to do a lossless IV/UV conversion.
7053
7054            Maybe could do some tricks with DBL_DIG, LDBL_DIG and
7055            DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
7056            as NV_DIG and NV_MANT_DIG)?
7057
7058            --jhi
7059            */
7060         {
7061             UV uv = U_V(nv);
7062             if (!floatit && (NV)uv == nv) {
7063                 if (uv <= IV_MAX)
7064                     sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7065                 else
7066                     sv_setuv(sv, uv);
7067             }
7068             else
7069                 sv_setnv(sv, nv);
7070         }
7071 #endif
7072         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7073                        (PL_hints & HINT_NEW_INTEGER) )
7074             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7075                               (floatit ? "float" : "integer"),
7076                               sv, Nullsv, NULL);
7077         break;
7078
7079     /* if it starts with a v, it could be a v-string */
7080     case 'v':
7081 vstring:
7082         {
7083             char *pos = s;
7084             pos++;
7085             while (isDIGIT(*pos) || *pos == '_')
7086                 pos++;
7087             if (!isALPHA(*pos)) {
7088                 UV rev;
7089                 U8 tmpbuf[UTF8_MAXLEN];
7090                 U8 *tmpend;
7091                 bool utf8 = FALSE;
7092                 s++;                            /* get past 'v' */
7093
7094                 sv = NEWSV(92,5);
7095                 sv_setpvn(sv, "", 0);
7096
7097                 for (;;) {
7098                     if (*s == '0' && isDIGIT(s[1]))
7099                         yyerror("Octal number in vector unsupported");
7100                     rev = 0;
7101                     {
7102                         /* this is atoi() that tolerates underscores */
7103                         char *end = pos;
7104                         UV mult = 1;
7105                         while (--end >= s) {
7106                             UV orev;
7107                             if (*end == '_')
7108                                 continue;
7109                             orev = rev;
7110                             rev += (*end - '0') * mult;
7111                             mult *= 10;
7112                             if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7113                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7114                                             "Integer overflow in decimal number");
7115                         }
7116                     }
7117                     tmpend = uv_to_utf8(tmpbuf, rev);
7118                     utf8 = utf8 || rev > 127;
7119                     sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7120                     if (*pos == '.' && isDIGIT(pos[1]))
7121                         s = ++pos;
7122                     else {
7123                         s = pos;
7124                         break;
7125                     }
7126                     while (isDIGIT(*pos) || *pos == '_')
7127                         pos++;
7128                 }
7129
7130                 SvPOK_on(sv);
7131                 SvREADONLY_on(sv);
7132                 if (utf8) {
7133                     SvUTF8_on(sv);
7134                     sv_utf8_downgrade(sv, TRUE);
7135                 }
7136             }
7137         }
7138         break;
7139     }
7140
7141     /* make the op for the constant and return */
7142
7143     if (sv)
7144         yylval.opval = newSVOP(OP_CONST, 0, sv);
7145     else
7146         yylval.opval = Nullop;
7147
7148     return s;
7149 }
7150
7151 STATIC char *
7152 S_scan_formline(pTHX_ register char *s)
7153 {
7154     dTHR;
7155     register char *eol;
7156     register char *t;
7157     SV *stuff = newSVpvn("",0);
7158     bool needargs = FALSE;
7159
7160     while (!needargs) {
7161         if (*s == '.' || *s == /*{*/'}') {
7162             /*SUPPRESS 530*/
7163 #ifdef PERL_STRICT_CR
7164             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7165 #else
7166             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7167 #endif
7168             if (*t == '\n' || t == PL_bufend)
7169                 break;
7170         }
7171         if (PL_in_eval && !PL_rsfp) {
7172             eol = strchr(s,'\n');
7173             if (!eol++)
7174                 eol = PL_bufend;
7175         }
7176         else
7177             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7178         if (*s != '#') {
7179             for (t = s; t < eol; t++) {
7180                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7181                     needargs = FALSE;
7182                     goto enough;        /* ~~ must be first line in formline */
7183                 }
7184                 if (*t == '@' || *t == '^')
7185                     needargs = TRUE;
7186             }
7187             sv_catpvn(stuff, s, eol-s);
7188 #ifndef PERL_STRICT_CR
7189             if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7190                 char *end = SvPVX(stuff) + SvCUR(stuff);
7191                 end[-2] = '\n';
7192                 end[-1] = '\0';
7193                 SvCUR(stuff)--;
7194             }
7195 #endif
7196         }
7197         s = eol;
7198         if (PL_rsfp) {
7199             s = filter_gets(PL_linestr, PL_rsfp, 0);
7200             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7201             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7202             if (!s) {
7203                 s = PL_bufptr;
7204                 yyerror("Format not terminated");
7205                 break;
7206             }
7207         }
7208         incline(s);
7209     }
7210   enough:
7211     if (SvCUR(stuff)) {
7212         PL_expect = XTERM;
7213         if (needargs) {
7214             PL_lex_state = LEX_NORMAL;
7215             PL_nextval[PL_nexttoke].ival = 0;
7216             force_next(',');
7217         }
7218         else
7219             PL_lex_state = LEX_FORMLINE;
7220         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7221         force_next(THING);
7222         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7223         force_next(LSTOP);
7224     }
7225     else {
7226         SvREFCNT_dec(stuff);
7227         PL_lex_formbrack = 0;
7228         PL_bufptr = s;
7229     }
7230     return s;
7231 }
7232
7233 STATIC void
7234 S_set_csh(pTHX)
7235 {
7236 #ifdef CSH
7237     if (!PL_cshlen)
7238         PL_cshlen = strlen(PL_cshname);
7239 #endif
7240 }
7241
7242 I32
7243 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7244 {
7245     dTHR;
7246     I32 oldsavestack_ix = PL_savestack_ix;
7247     CV* outsidecv = PL_compcv;
7248     AV* comppadlist;
7249
7250     if (PL_compcv) {
7251         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7252     }
7253     SAVEI32(PL_subline);
7254     save_item(PL_subname);
7255     SAVEI32(PL_padix);
7256     SAVECOMPPAD();
7257     SAVESPTR(PL_comppad_name);
7258     SAVESPTR(PL_compcv);
7259     SAVEI32(PL_comppad_name_fill);
7260     SAVEI32(PL_min_intro_pending);
7261     SAVEI32(PL_max_intro_pending);
7262     SAVEI32(PL_pad_reset_pending);
7263
7264     PL_compcv = (CV*)NEWSV(1104,0);
7265     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7266     CvFLAGS(PL_compcv) |= flags;
7267
7268     PL_comppad = newAV();
7269     av_push(PL_comppad, Nullsv);
7270     PL_curpad = AvARRAY(PL_comppad);
7271     PL_comppad_name = newAV();
7272     PL_comppad_name_fill = 0;
7273     PL_min_intro_pending = 0;
7274     PL_padix = 0;
7275     PL_subline = CopLINE(PL_curcop);
7276 #ifdef USE_THREADS
7277     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7278     PL_curpad[0] = (SV*)newAV();
7279     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7280 #endif /* USE_THREADS */
7281
7282     comppadlist = newAV();
7283     AvREAL_off(comppadlist);
7284     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7285     av_store(comppadlist, 1, (SV*)PL_comppad);
7286
7287     CvPADLIST(PL_compcv) = comppadlist;
7288     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7289 #ifdef USE_THREADS
7290     CvOWNER(PL_compcv) = 0;
7291     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7292     MUTEX_INIT(CvMUTEXP(PL_compcv));
7293 #endif /* USE_THREADS */
7294
7295     return oldsavestack_ix;
7296 }
7297
7298 int
7299 Perl_yywarn(pTHX_ char *s)
7300 {
7301     dTHR;
7302     PL_in_eval |= EVAL_WARNONLY;
7303     yyerror(s);
7304     PL_in_eval &= ~EVAL_WARNONLY;
7305     return 0;
7306 }
7307
7308 int
7309 Perl_yyerror(pTHX_ char *s)
7310 {
7311     dTHR;
7312     char *where = NULL;
7313     char *context = NULL;
7314     int contlen = -1;
7315     SV *msg;
7316
7317     if (!yychar || (yychar == ';' && !PL_rsfp))
7318         where = "at EOF";
7319     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7320       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7321         while (isSPACE(*PL_oldoldbufptr))
7322             PL_oldoldbufptr++;
7323         context = PL_oldoldbufptr;
7324         contlen = PL_bufptr - PL_oldoldbufptr;
7325     }
7326     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7327       PL_oldbufptr != PL_bufptr) {
7328         while (isSPACE(*PL_oldbufptr))
7329             PL_oldbufptr++;
7330         context = PL_oldbufptr;
7331         contlen = PL_bufptr - PL_oldbufptr;
7332     }
7333     else if (yychar > 255)
7334         where = "next token ???";
7335 #ifdef USE_PURE_BISON
7336 /*  GNU Bison sets the value -2 */
7337     else if (yychar == -2) {
7338 #else
7339     else if ((yychar & 127) == 127) {
7340 #endif
7341         if (PL_lex_state == LEX_NORMAL ||
7342            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7343             where = "at end of line";
7344         else if (PL_lex_inpat)
7345             where = "within pattern";
7346         else
7347             where = "within string";
7348     }
7349     else {
7350         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7351         if (yychar < 32)
7352             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7353         else if (isPRINT_LC(yychar))
7354             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7355         else
7356             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7357         where = SvPVX(where_sv);
7358     }
7359     msg = sv_2mortal(newSVpv(s, 0));
7360     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7361                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7362     if (context)
7363         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7364     else
7365         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7366     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7367         Perl_sv_catpvf(aTHX_ msg,
7368         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7369                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7370         PL_multi_end = 0;
7371     }
7372     if (PL_in_eval & EVAL_WARNONLY)
7373         Perl_warn(aTHX_ "%"SVf, msg);
7374     else
7375         qerror(msg);
7376     if (PL_error_count >= 10) {
7377         if (PL_in_eval && SvCUR(ERRSV))
7378             Perl_croak(aTHX_ "%_%s has too many errors.\n",
7379                        ERRSV, CopFILE(PL_curcop));
7380         else
7381             Perl_croak(aTHX_ "%s has too many errors.\n",
7382                        CopFILE(PL_curcop));
7383     }
7384     PL_in_my = 0;
7385     PL_in_my_stash = Nullhv;
7386     return 0;
7387 }
7388
7389 STATIC char*
7390 S_swallow_bom(pTHX_ U8 *s)
7391 {
7392     STRLEN slen;
7393     slen = SvCUR(PL_linestr);
7394     switch (*s) {
7395     case 0xFF:
7396         if (s[1] == 0xFE) {
7397             /* UTF-16 little-endian */
7398 #ifndef PERL_NO_UTF16_FILTER
7399             U8 *news;
7400 #endif
7401             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7402                 Perl_croak(aTHX_ "Unsupported script encoding");
7403 #ifndef PERL_NO_UTF16_FILTER
7404             s += 2;
7405             filter_add(utf16rev_textfilter, NULL);
7406             New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7407             PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
7408                                              PL_bufend - (char*)s);
7409             s = news;
7410 #else
7411             Perl_croak(aTHX_ "Unsupported script encoding");
7412 #endif
7413         }
7414         break;
7415     case 0xFE:
7416         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7417 #ifndef PERL_NO_UTF16_FILTER
7418             U8 *news;
7419             filter_add(utf16_textfilter, NULL);
7420             New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7421             PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
7422                                              PL_bufend - (char*)s);
7423             s = news;
7424 #else
7425             Perl_croak(aTHX_ "Unsupported script encoding");
7426 #endif
7427         }
7428         break;
7429     case 0xEF:
7430         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7431             s += 3;                      /* UTF-8 */
7432         }
7433         break;
7434     case 0:
7435         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7436             s[2] == 0xFE && s[3] == 0xFF)
7437         {
7438             Perl_croak(aTHX_ "Unsupported script encoding");
7439         }
7440     }
7441     return (char*)s;
7442 }
7443
7444 #ifdef PERL_OBJECT
7445 #include "XSUB.h"
7446 #endif
7447
7448 /*
7449  * restore_rsfp
7450  * Restore a source filter.
7451  */
7452
7453 static void
7454 restore_rsfp(pTHXo_ void *f)
7455 {
7456     PerlIO *fp = (PerlIO*)f;
7457
7458     if (PL_rsfp == PerlIO_stdin())
7459         PerlIO_clearerr(PL_rsfp);
7460     else if (PL_rsfp && (PL_rsfp != fp))
7461         PerlIO_close(PL_rsfp);
7462     PL_rsfp = fp;
7463 }
7464
7465 #ifndef PERL_NO_UTF16_FILTER
7466 static I32
7467 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7468 {
7469     I32 count = FILTER_READ(idx+1, sv, maxlen);
7470     if (count) {
7471         U8* tmps;
7472         U8* tend;
7473         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7474         tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
7475         sv_usepvn(sv, (char*)tmps, tend - tmps);
7476     }
7477     return count;
7478 }
7479
7480 static I32
7481 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7482 {
7483     I32 count = FILTER_READ(idx+1, sv, maxlen);
7484     if (count) {
7485         U8* tmps;
7486         U8* tend;
7487         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7488         tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
7489         sv_usepvn(sv, (char*)tmps, tend - tmps);
7490     }
7491     return count;
7492 }
7493 #endif