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