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