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