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