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 == XTERM) {
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         }
3481         goto keylookup;
3482     case 'x':
3483         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3484             s++;
3485             Mop(OP_REPEAT);
3486         }
3487         goto keylookup;
3488
3489     case '_':
3490     case 'a': case 'A':
3491     case 'b': case 'B':
3492     case 'c': case 'C':
3493     case 'd': case 'D':
3494     case 'e': case 'E':
3495     case 'f': case 'F':
3496     case 'g': case 'G':
3497     case 'h': case 'H':
3498     case 'i': case 'I':
3499     case 'j': case 'J':
3500     case 'k': case 'K':
3501     case 'l': case 'L':
3502     case 'm': case 'M':
3503     case 'n': case 'N':
3504     case 'o': case 'O':
3505     case 'p': case 'P':
3506     case 'q': case 'Q':
3507     case 'r': case 'R':
3508     case 's': case 'S':
3509     case 't': case 'T':
3510     case 'u': case 'U':
3511               case 'V':
3512     case 'w': case 'W':
3513               case 'X':
3514     case 'y': case 'Y':
3515     case 'z': case 'Z':
3516
3517       keylookup: {
3518         STRLEN n_a;
3519         gv = Nullgv;
3520         gvp = 0;
3521
3522         PL_bufptr = s;
3523         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3524
3525         /* Some keywords can be followed by any delimiter, including ':' */
3526         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3527                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3528                             (PL_tokenbuf[0] == 'q' &&
3529                              strchr("qwxr", PL_tokenbuf[1]))));
3530
3531         /* x::* is just a word, unless x is "CORE" */
3532         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3533             goto just_a_word;
3534
3535         d = s;
3536         while (d < PL_bufend && isSPACE(*d))
3537                 d++;    /* no comments skipped here, or s### is misparsed */
3538
3539         /* Is this a label? */
3540         if (!tmp && PL_expect == XSTATE
3541               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3542             s = d + 1;
3543             yylval.pval = savepv(PL_tokenbuf);
3544             CLINE;
3545             TOKEN(LABEL);
3546         }
3547
3548         /* Check for keywords */
3549         tmp = keyword(PL_tokenbuf, len);
3550
3551         /* Is this a word before a => operator? */
3552         if (strnEQ(d,"=>",2)) {
3553             CLINE;
3554             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3555             yylval.opval->op_private = OPpCONST_BARE;
3556             TERM(WORD);
3557         }
3558
3559         if (tmp < 0) {                  /* second-class keyword? */
3560             GV *ogv = Nullgv;   /* override (winner) */
3561             GV *hgv = Nullgv;   /* hidden (loser) */
3562             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3563                 CV *cv;
3564                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3565                     (cv = GvCVu(gv)))
3566                 {
3567                     if (GvIMPORTED_CV(gv))
3568                         ogv = gv;
3569                     else if (! CvMETHOD(cv))
3570                         hgv = gv;
3571                 }
3572                 if (!ogv &&
3573                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3574                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3575                     GvCVu(gv) && GvIMPORTED_CV(gv))
3576                 {
3577                     ogv = gv;
3578                 }
3579             }
3580             if (ogv) {
3581                 tmp = 0;                /* overridden by import or by GLOBAL */
3582             }
3583             else if (gv && !gvp
3584                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3585                      && GvCVu(gv)
3586                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3587             {
3588                 tmp = 0;                /* any sub overrides "weak" keyword */
3589             }
3590             else {                      /* no override */
3591                 tmp = -tmp;
3592                 gv = Nullgv;
3593                 gvp = 0;
3594                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3595                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3596                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3597                         "Ambiguous call resolved as CORE::%s(), %s",
3598                          GvENAME(hgv), "qualify as such or use &");
3599             }
3600         }
3601
3602       reserved_word:
3603         switch (tmp) {
3604
3605         default:                        /* not a keyword */
3606           just_a_word: {
3607                 SV *sv;
3608                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3609
3610                 /* Get the rest if it looks like a package qualifier */
3611
3612                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3613                     STRLEN morelen;
3614                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3615                                   TRUE, &morelen);
3616                     if (!morelen)
3617                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3618                                 *s == '\'' ? "'" : "::");
3619                     len += morelen;
3620                 }
3621
3622                 if (PL_expect == XOPERATOR) {
3623                     if (PL_bufptr == PL_linestart) {
3624                         CopLINE_dec(PL_curcop);
3625                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3626                         CopLINE_inc(PL_curcop);
3627                     }
3628                     else
3629                         no_op("Bareword",s);
3630                 }
3631
3632                 /* Look for a subroutine with this name in current package,
3633                    unless name is "Foo::", in which case Foo is a bearword
3634                    (and a package name). */
3635
3636                 if (len > 2 &&
3637                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3638                 {
3639                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3640                         Perl_warner(aTHX_ WARN_BAREWORD,
3641                             "Bareword \"%s\" refers to nonexistent package",
3642                              PL_tokenbuf);
3643                     len -= 2;
3644                     PL_tokenbuf[len] = '\0';
3645                     gv = Nullgv;
3646                     gvp = 0;
3647                 }
3648                 else {
3649                     len = 0;
3650                     if (!gv)
3651                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3652                 }
3653
3654                 /* if we saw a global override before, get the right name */
3655
3656                 if (gvp) {
3657                     sv = newSVpvn("CORE::GLOBAL::",14);
3658                     sv_catpv(sv,PL_tokenbuf);
3659                 }
3660                 else
3661                     sv = newSVpv(PL_tokenbuf,0);
3662
3663                 /* Presume this is going to be a bareword of some sort. */
3664
3665                 CLINE;
3666                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3667                 yylval.opval->op_private = OPpCONST_BARE;
3668
3669                 /* And if "Foo::", then that's what it certainly is. */
3670
3671                 if (len)
3672                     goto safe_bareword;
3673
3674                 /* See if it's the indirect object for a list operator. */
3675
3676                 if (PL_oldoldbufptr &&
3677                     PL_oldoldbufptr < PL_bufptr &&
3678                     (PL_oldoldbufptr == PL_last_lop
3679                      || PL_oldoldbufptr == PL_last_uni) &&
3680                     /* NO SKIPSPACE BEFORE HERE! */
3681                     (PL_expect == XREF ||
3682                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3683                 {
3684                     bool immediate_paren = *s == '(';
3685
3686                     /* (Now we can afford to cross potential line boundary.) */
3687                     s = skipspace(s);
3688
3689                     /* Two barewords in a row may indicate method call. */
3690
3691                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3692                         return tmp;
3693
3694                     /* If not a declared subroutine, it's an indirect object. */
3695                     /* (But it's an indir obj regardless for sort.) */
3696
3697                     if ((PL_last_lop_op == OP_SORT ||
3698                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3699                         (PL_last_lop_op != OP_MAPSTART &&
3700                          PL_last_lop_op != OP_GREPSTART))
3701                     {
3702                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3703                         goto bareword;
3704                     }
3705                 }
3706
3707                 /* If followed by a paren, it's certainly a subroutine. */
3708
3709                 PL_expect = XOPERATOR;
3710                 s = skipspace(s);
3711                 if (*s == '(') {
3712                     CLINE;
3713                     if (gv && GvCVu(gv)) {
3714                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3715                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3716                             s = d + 1;
3717                             goto its_constant;
3718                         }
3719                     }
3720                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3721                     PL_expect = XOPERATOR;
3722                     force_next(WORD);
3723                     yylval.ival = 0;
3724                     TOKEN('&');
3725                 }
3726
3727                 /* If followed by var or block, call it a method (unless sub) */
3728
3729                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3730                     PL_last_lop = PL_oldbufptr;
3731                     PL_last_lop_op = OP_METHOD;
3732                     PREBLOCK(METHOD);
3733                 }
3734
3735                 /* If followed by a bareword, see if it looks like indir obj. */
3736
3737                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3738                     return tmp;
3739
3740                 /* Not a method, so call it a subroutine (if defined) */
3741
3742                 if (gv && GvCVu(gv)) {
3743                     CV* cv;
3744                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3745                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3746                                 "Ambiguous use of -%s resolved as -&%s()",
3747                                 PL_tokenbuf, PL_tokenbuf);
3748                     /* Check for a constant sub */
3749                     cv = GvCV(gv);
3750                     if ((sv = cv_const_sv(cv))) {
3751                   its_constant:
3752                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3753                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3754                         yylval.opval->op_private = 0;
3755                         TOKEN(WORD);
3756                     }
3757
3758                     /* Resolve to GV now. */
3759                     op_free(yylval.opval);
3760                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3761                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3762                     PL_last_lop = PL_oldbufptr;
3763                     PL_last_lop_op = OP_ENTERSUB;
3764                     /* Is there a prototype? */
3765                     if (SvPOK(cv)) {
3766                         STRLEN len;
3767                         char *proto = SvPV((SV*)cv, len);
3768                         if (!len)
3769                             TERM(FUNC0SUB);
3770                         if (strEQ(proto, "$"))
3771                             OPERATOR(UNIOPSUB);
3772                         if (*proto == '&' && *s == '{') {
3773                             sv_setpv(PL_subname,"__ANON__");
3774                             PREBLOCK(LSTOPSUB);
3775                         }
3776                     }
3777                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3778                     PL_expect = XTERM;
3779                     force_next(WORD);
3780                     TOKEN(NOAMP);
3781                 }
3782
3783                 /* Call it a bare word */
3784
3785                 if (PL_hints & HINT_STRICT_SUBS)
3786                     yylval.opval->op_private |= OPpCONST_STRICT;
3787                 else {
3788                 bareword:
3789                     if (ckWARN(WARN_RESERVED)) {
3790                         if (lastchar != '-') {
3791                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3792                             if (!*d)
3793                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3794                                        PL_tokenbuf);
3795                         }
3796                     }
3797                 }
3798
3799             safe_bareword:
3800                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3801                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3802                         "Operator or semicolon missing before %c%s",
3803                         lastchar, PL_tokenbuf);
3804                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3805                         "Ambiguous use of %c resolved as operator %c",
3806                         lastchar, lastchar);
3807                 }
3808                 TOKEN(WORD);
3809             }
3810
3811         case KEY___FILE__:
3812             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3813                                         newSVpv(CopFILE(PL_curcop),0));
3814             TERM(THING);
3815
3816         case KEY___LINE__:
3817             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3818                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3819             TERM(THING);
3820
3821         case KEY___PACKAGE__:
3822             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3823                                         (PL_curstash
3824                                          ? newSVsv(PL_curstname)
3825                                          : &PL_sv_undef));
3826             TERM(THING);
3827
3828         case KEY___DATA__:
3829         case KEY___END__: {
3830             GV *gv;
3831
3832             /*SUPPRESS 560*/
3833             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3834                 char *pname = "main";
3835                 if (PL_tokenbuf[2] == 'D')
3836                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3837                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3838                 GvMULTI_on(gv);
3839                 if (!GvIO(gv))
3840                     GvIOp(gv) = newIO();
3841                 IoIFP(GvIOp(gv)) = PL_rsfp;
3842 #if defined(HAS_FCNTL) && defined(F_SETFD)
3843                 {
3844                     int fd = PerlIO_fileno(PL_rsfp);
3845                     fcntl(fd,F_SETFD,fd >= 3);
3846                 }
3847 #endif
3848                 /* Mark this internal pseudo-handle as clean */
3849                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3850                 if (PL_preprocess)
3851                     IoTYPE(GvIOp(gv)) = '|';
3852                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3853                     IoTYPE(GvIOp(gv)) = '-';
3854                 else
3855                     IoTYPE(GvIOp(gv)) = '<';
3856 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3857                 /* if the script was opened in binmode, we need to revert
3858                  * it to text mode for compatibility; but only iff it has CRs
3859                  * XXX this is a questionable hack at best. */
3860                 if (PL_bufend-PL_bufptr > 2
3861                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3862                 {
3863                     Off_t loc = 0;
3864                     if (IoTYPE(GvIOp(gv)) == '<') {
3865                         loc = PerlIO_tell(PL_rsfp);
3866                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
3867                     }
3868                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3869 #if defined(__BORLANDC__)
3870                         /* XXX see note in do_binmode() */
3871                         ((FILE*)PL_rsfp)->flags |= _F_BIN;
3872 #endif
3873                         if (loc > 0)
3874                             PerlIO_seek(PL_rsfp, loc, 0);
3875                     }
3876                 }
3877 #endif
3878                 PL_rsfp = Nullfp;
3879             }
3880             goto fake_eof;
3881         }
3882
3883         case KEY_AUTOLOAD:
3884         case KEY_DESTROY:
3885         case KEY_BEGIN:
3886         case KEY_CHECK:
3887         case KEY_INIT:
3888         case KEY_END:
3889             if (PL_expect == XSTATE) {
3890                 s = PL_bufptr;
3891                 goto really_sub;
3892             }
3893             goto just_a_word;
3894
3895         case KEY_CORE:
3896             if (*s == ':' && s[1] == ':') {
3897                 s += 2;
3898                 d = s;
3899                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3900                 tmp = keyword(PL_tokenbuf, len);
3901                 if (tmp < 0)
3902                     tmp = -tmp;
3903                 goto reserved_word;
3904             }
3905             goto just_a_word;
3906
3907         case KEY_abs:
3908             UNI(OP_ABS);
3909
3910         case KEY_alarm:
3911             UNI(OP_ALARM);
3912
3913         case KEY_accept:
3914             LOP(OP_ACCEPT,XTERM);
3915
3916         case KEY_and:
3917             OPERATOR(ANDOP);
3918
3919         case KEY_atan2:
3920             LOP(OP_ATAN2,XTERM);
3921
3922         case KEY_bind:
3923             LOP(OP_BIND,XTERM);
3924
3925         case KEY_binmode:
3926             UNI(OP_BINMODE);
3927
3928         case KEY_bless:
3929             LOP(OP_BLESS,XTERM);
3930
3931         case KEY_chop:
3932             UNI(OP_CHOP);
3933
3934         case KEY_continue:
3935             PREBLOCK(CONTINUE);
3936
3937         case KEY_chdir:
3938             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3939             UNI(OP_CHDIR);
3940
3941         case KEY_close:
3942             UNI(OP_CLOSE);
3943
3944         case KEY_closedir:
3945             UNI(OP_CLOSEDIR);
3946
3947         case KEY_cmp:
3948             Eop(OP_SCMP);
3949
3950         case KEY_caller:
3951             UNI(OP_CALLER);
3952
3953         case KEY_crypt:
3954 #ifdef FCRYPT
3955             if (!PL_cryptseen) {
3956                 PL_cryptseen = TRUE;
3957                 init_des();
3958             }
3959 #endif
3960             LOP(OP_CRYPT,XTERM);
3961
3962         case KEY_chmod:
3963             if (ckWARN(WARN_CHMOD)) {
3964                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3965                 if (*d != '0' && isDIGIT(*d))
3966                     Perl_warner(aTHX_ WARN_CHMOD,
3967                                 "chmod() mode argument is missing initial 0");
3968             }
3969             LOP(OP_CHMOD,XTERM);
3970
3971         case KEY_chown:
3972             LOP(OP_CHOWN,XTERM);
3973
3974         case KEY_connect:
3975             LOP(OP_CONNECT,XTERM);
3976
3977         case KEY_chr:
3978             UNI(OP_CHR);
3979
3980         case KEY_cos:
3981             UNI(OP_COS);
3982
3983         case KEY_chroot:
3984             UNI(OP_CHROOT);
3985
3986         case KEY_do:
3987             s = skipspace(s);
3988             if (*s == '{')
3989                 PRETERMBLOCK(DO);
3990             if (*s != '\'')
3991                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3992             OPERATOR(DO);
3993
3994         case KEY_die:
3995             PL_hints |= HINT_BLOCK_SCOPE;
3996             LOP(OP_DIE,XTERM);
3997
3998         case KEY_defined:
3999             UNI(OP_DEFINED);
4000
4001         case KEY_delete:
4002             UNI(OP_DELETE);
4003
4004         case KEY_dbmopen:
4005             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4006             LOP(OP_DBMOPEN,XTERM);
4007
4008         case KEY_dbmclose:
4009             UNI(OP_DBMCLOSE);
4010
4011         case KEY_dump:
4012             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4013             LOOPX(OP_DUMP);
4014
4015         case KEY_else:
4016             PREBLOCK(ELSE);
4017
4018         case KEY_elsif:
4019             yylval.ival = CopLINE(PL_curcop);
4020             OPERATOR(ELSIF);
4021
4022         case KEY_eq:
4023             Eop(OP_SEQ);
4024
4025         case KEY_exists:
4026             UNI(OP_EXISTS);
4027
4028         case KEY_exit:
4029             UNI(OP_EXIT);
4030
4031         case KEY_eval:
4032             s = skipspace(s);
4033             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4034             UNIBRACK(OP_ENTEREVAL);
4035
4036         case KEY_eof:
4037             UNI(OP_EOF);
4038
4039         case KEY_exp:
4040             UNI(OP_EXP);
4041
4042         case KEY_each:
4043             UNI(OP_EACH);
4044
4045         case KEY_exec:
4046             set_csh();
4047             LOP(OP_EXEC,XREF);
4048
4049         case KEY_endhostent:
4050             FUN0(OP_EHOSTENT);
4051
4052         case KEY_endnetent:
4053             FUN0(OP_ENETENT);
4054
4055         case KEY_endservent:
4056             FUN0(OP_ESERVENT);
4057
4058         case KEY_endprotoent:
4059             FUN0(OP_EPROTOENT);
4060
4061         case KEY_endpwent:
4062             FUN0(OP_EPWENT);
4063
4064         case KEY_endgrent:
4065             FUN0(OP_EGRENT);
4066
4067         case KEY_for:
4068         case KEY_foreach:
4069             yylval.ival = CopLINE(PL_curcop);
4070             s = skipspace(s);
4071             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4072                 char *p = s;
4073                 if ((PL_bufend - p) >= 3 &&
4074                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4075                     p += 2;
4076                 else if ((PL_bufend - p) >= 4 &&
4077                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4078                     p += 3;
4079                 p = skipspace(p);
4080                 if (isIDFIRST_lazy_if(p,UTF)) {
4081                     p = scan_ident(p, PL_bufend,
4082                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4083                     p = skipspace(p);
4084                 }
4085                 if (*p != '$')
4086                     Perl_croak(aTHX_ "Missing $ on loop variable");
4087             }
4088             OPERATOR(FOR);
4089
4090         case KEY_formline:
4091             LOP(OP_FORMLINE,XTERM);
4092
4093         case KEY_fork:
4094             FUN0(OP_FORK);
4095
4096         case KEY_fcntl:
4097             LOP(OP_FCNTL,XTERM);
4098
4099         case KEY_fileno:
4100             UNI(OP_FILENO);
4101
4102         case KEY_flock:
4103             LOP(OP_FLOCK,XTERM);
4104
4105         case KEY_gt:
4106             Rop(OP_SGT);
4107
4108         case KEY_ge:
4109             Rop(OP_SGE);
4110
4111         case KEY_grep:
4112             LOP(OP_GREPSTART, XREF);
4113
4114         case KEY_goto:
4115             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4116             LOOPX(OP_GOTO);
4117
4118         case KEY_gmtime:
4119             UNI(OP_GMTIME);
4120
4121         case KEY_getc:
4122             UNI(OP_GETC);
4123
4124         case KEY_getppid:
4125             FUN0(OP_GETPPID);
4126
4127         case KEY_getpgrp:
4128             UNI(OP_GETPGRP);
4129
4130         case KEY_getpriority:
4131             LOP(OP_GETPRIORITY,XTERM);
4132
4133         case KEY_getprotobyname:
4134             UNI(OP_GPBYNAME);
4135
4136         case KEY_getprotobynumber:
4137             LOP(OP_GPBYNUMBER,XTERM);
4138
4139         case KEY_getprotoent:
4140             FUN0(OP_GPROTOENT);
4141
4142         case KEY_getpwent:
4143             FUN0(OP_GPWENT);
4144
4145         case KEY_getpwnam:
4146             UNI(OP_GPWNAM);
4147
4148         case KEY_getpwuid:
4149             UNI(OP_GPWUID);
4150
4151         case KEY_getpeername:
4152             UNI(OP_GETPEERNAME);
4153
4154         case KEY_gethostbyname:
4155             UNI(OP_GHBYNAME);
4156
4157         case KEY_gethostbyaddr:
4158             LOP(OP_GHBYADDR,XTERM);
4159
4160         case KEY_gethostent:
4161             FUN0(OP_GHOSTENT);
4162
4163         case KEY_getnetbyname:
4164             UNI(OP_GNBYNAME);
4165
4166         case KEY_getnetbyaddr:
4167             LOP(OP_GNBYADDR,XTERM);
4168
4169         case KEY_getnetent:
4170             FUN0(OP_GNETENT);
4171
4172         case KEY_getservbyname:
4173             LOP(OP_GSBYNAME,XTERM);
4174
4175         case KEY_getservbyport:
4176             LOP(OP_GSBYPORT,XTERM);
4177
4178         case KEY_getservent:
4179             FUN0(OP_GSERVENT);
4180
4181         case KEY_getsockname:
4182             UNI(OP_GETSOCKNAME);
4183
4184         case KEY_getsockopt:
4185             LOP(OP_GSOCKOPT,XTERM);
4186
4187         case KEY_getgrent:
4188             FUN0(OP_GGRENT);
4189
4190         case KEY_getgrnam:
4191             UNI(OP_GGRNAM);
4192
4193         case KEY_getgrgid:
4194             UNI(OP_GGRGID);
4195
4196         case KEY_getlogin:
4197             FUN0(OP_GETLOGIN);
4198
4199         case KEY_glob:
4200             set_csh();
4201             LOP(OP_GLOB,XTERM);
4202
4203         case KEY_hex:
4204             UNI(OP_HEX);
4205
4206         case KEY_if:
4207             yylval.ival = CopLINE(PL_curcop);
4208             OPERATOR(IF);
4209
4210         case KEY_index:
4211             LOP(OP_INDEX,XTERM);
4212
4213         case KEY_int:
4214             UNI(OP_INT);
4215
4216         case KEY_ioctl:
4217             LOP(OP_IOCTL,XTERM);
4218
4219         case KEY_join:
4220             LOP(OP_JOIN,XTERM);
4221
4222         case KEY_keys:
4223             UNI(OP_KEYS);
4224
4225         case KEY_kill:
4226             LOP(OP_KILL,XTERM);
4227
4228         case KEY_last:
4229             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4230             LOOPX(OP_LAST);
4231
4232         case KEY_lc:
4233             UNI(OP_LC);
4234
4235         case KEY_lcfirst:
4236             UNI(OP_LCFIRST);
4237
4238         case KEY_local:
4239             yylval.ival = 0;
4240             OPERATOR(LOCAL);
4241
4242         case KEY_length:
4243             UNI(OP_LENGTH);
4244
4245         case KEY_lt:
4246             Rop(OP_SLT);
4247
4248         case KEY_le:
4249             Rop(OP_SLE);
4250
4251         case KEY_localtime:
4252             UNI(OP_LOCALTIME);
4253
4254         case KEY_log:
4255             UNI(OP_LOG);
4256
4257         case KEY_link:
4258             LOP(OP_LINK,XTERM);
4259
4260         case KEY_listen:
4261             LOP(OP_LISTEN,XTERM);
4262
4263         case KEY_lock:
4264             UNI(OP_LOCK);
4265
4266         case KEY_lstat:
4267             UNI(OP_LSTAT);
4268
4269         case KEY_m:
4270             s = scan_pat(s,OP_MATCH);
4271             TERM(sublex_start());
4272
4273         case KEY_map:
4274             LOP(OP_MAPSTART, XREF);
4275
4276         case KEY_mkdir:
4277             LOP(OP_MKDIR,XTERM);
4278
4279         case KEY_msgctl:
4280             LOP(OP_MSGCTL,XTERM);
4281
4282         case KEY_msgget:
4283             LOP(OP_MSGGET,XTERM);
4284
4285         case KEY_msgrcv:
4286             LOP(OP_MSGRCV,XTERM);
4287
4288         case KEY_msgsnd:
4289             LOP(OP_MSGSND,XTERM);
4290
4291         case KEY_our:
4292         case KEY_my:
4293             PL_in_my = tmp;
4294             s = skipspace(s);
4295             if (isIDFIRST_lazy_if(s,UTF)) {
4296                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4297                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4298                     goto really_sub;
4299                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4300                 if (!PL_in_my_stash) {
4301                     char tmpbuf[1024];
4302                     PL_bufptr = s;
4303                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4304                     yyerror(tmpbuf);
4305                 }
4306             }
4307             yylval.ival = 1;
4308             OPERATOR(MY);
4309
4310         case KEY_next:
4311             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4312             LOOPX(OP_NEXT);
4313
4314         case KEY_ne:
4315             Eop(OP_SNE);
4316
4317         case KEY_no:
4318             if (PL_expect != XSTATE)
4319                 yyerror("\"no\" not allowed in expression");
4320             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4321             s = force_version(s);
4322             yylval.ival = 0;
4323             OPERATOR(USE);
4324
4325         case KEY_not:
4326             if (*s == '(' || (s = skipspace(s), *s == '('))
4327                 FUN1(OP_NOT);
4328             else
4329                 OPERATOR(NOTOP);
4330
4331         case KEY_open:
4332             s = skipspace(s);
4333             if (isIDFIRST_lazy_if(s,UTF)) {
4334                 char *t;
4335                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4336                 t = skipspace(d);
4337                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4338                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4339                            "Precedence problem: open %.*s should be open(%.*s)",
4340                             d-s,s, d-s,s);
4341             }
4342             LOP(OP_OPEN,XTERM);
4343
4344         case KEY_or:
4345             yylval.ival = OP_OR;
4346             OPERATOR(OROP);
4347
4348         case KEY_ord:
4349             UNI(OP_ORD);
4350
4351         case KEY_oct:
4352             UNI(OP_OCT);
4353
4354         case KEY_opendir:
4355             LOP(OP_OPEN_DIR,XTERM);
4356
4357         case KEY_print:
4358             checkcomma(s,PL_tokenbuf,"filehandle");
4359             LOP(OP_PRINT,XREF);
4360
4361         case KEY_printf:
4362             checkcomma(s,PL_tokenbuf,"filehandle");
4363             LOP(OP_PRTF,XREF);
4364
4365         case KEY_prototype:
4366             UNI(OP_PROTOTYPE);
4367
4368         case KEY_push:
4369             LOP(OP_PUSH,XTERM);
4370
4371         case KEY_pop:
4372             UNI(OP_POP);
4373
4374         case KEY_pos:
4375             UNI(OP_POS);
4376
4377         case KEY_pack:
4378             LOP(OP_PACK,XTERM);
4379
4380         case KEY_package:
4381             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4382             OPERATOR(PACKAGE);
4383
4384         case KEY_pipe:
4385             LOP(OP_PIPE_OP,XTERM);
4386
4387         case KEY_q:
4388             s = scan_str(s,FALSE,FALSE);
4389             if (!s)
4390                 missingterm((char*)0);
4391             yylval.ival = OP_CONST;
4392             TERM(sublex_start());
4393
4394         case KEY_quotemeta:
4395             UNI(OP_QUOTEMETA);
4396
4397         case KEY_qw:
4398             s = scan_str(s,FALSE,FALSE);
4399             if (!s)
4400                 missingterm((char*)0);
4401             force_next(')');
4402             if (SvCUR(PL_lex_stuff)) {
4403                 OP *words = Nullop;
4404                 int warned = 0;
4405                 d = SvPV_force(PL_lex_stuff, len);
4406                 while (len) {
4407                     for (; isSPACE(*d) && len; --len, ++d) ;
4408                     if (len) {
4409                         char *b = d;
4410                         if (!warned && ckWARN(WARN_QW)) {
4411                             for (; !isSPACE(*d) && len; --len, ++d) {
4412                                 if (*d == ',') {
4413                                     Perl_warner(aTHX_ WARN_QW,
4414                                         "Possible attempt to separate words with commas");
4415                                     ++warned;
4416                                 }
4417                                 else if (*d == '#') {
4418                                     Perl_warner(aTHX_ WARN_QW,
4419                                         "Possible attempt to put comments in qw() list");
4420                                     ++warned;
4421                                 }
4422                             }
4423                         }
4424                         else {
4425                             for (; !isSPACE(*d) && len; --len, ++d) ;
4426                         }
4427                         words = append_elem(OP_LIST, words,
4428                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4429                     }
4430                 }
4431                 if (words) {
4432                     PL_nextval[PL_nexttoke].opval = words;
4433                     force_next(THING);
4434                 }
4435             }
4436             if (PL_lex_stuff)
4437                 SvREFCNT_dec(PL_lex_stuff);
4438             PL_lex_stuff = Nullsv;
4439             PL_expect = XTERM;
4440             TOKEN('(');
4441
4442         case KEY_qq:
4443             s = scan_str(s,FALSE,FALSE);
4444             if (!s)
4445                 missingterm((char*)0);
4446             yylval.ival = OP_STRINGIFY;
4447             if (SvIVX(PL_lex_stuff) == '\'')
4448                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4449             TERM(sublex_start());
4450
4451         case KEY_qr:
4452             s = scan_pat(s,OP_QR);
4453             TERM(sublex_start());
4454
4455         case KEY_qx:
4456             s = scan_str(s,FALSE,FALSE);
4457             if (!s)
4458                 missingterm((char*)0);
4459             yylval.ival = OP_BACKTICK;
4460             set_csh();
4461             TERM(sublex_start());
4462
4463         case KEY_return:
4464             OLDLOP(OP_RETURN);
4465
4466         case KEY_require:
4467             s = skipspace(s);
4468             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4469                 s = force_version(s);
4470             }
4471             else {
4472                 *PL_tokenbuf = '\0';
4473                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4474                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4475                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4476                 else if (*s == '<')
4477                     yyerror("<> should be quotes");
4478             }
4479             UNI(OP_REQUIRE);
4480
4481         case KEY_reset:
4482             UNI(OP_RESET);
4483
4484         case KEY_redo:
4485             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4486             LOOPX(OP_REDO);
4487
4488         case KEY_rename:
4489             LOP(OP_RENAME,XTERM);
4490
4491         case KEY_rand:
4492             UNI(OP_RAND);
4493
4494         case KEY_rmdir:
4495             UNI(OP_RMDIR);
4496
4497         case KEY_rindex:
4498             LOP(OP_RINDEX,XTERM);
4499
4500         case KEY_read:
4501             LOP(OP_READ,XTERM);
4502
4503         case KEY_readdir:
4504             UNI(OP_READDIR);
4505
4506         case KEY_readline:
4507             set_csh();
4508             UNI(OP_READLINE);
4509
4510         case KEY_readpipe:
4511             set_csh();
4512             UNI(OP_BACKTICK);
4513
4514         case KEY_rewinddir:
4515             UNI(OP_REWINDDIR);
4516
4517         case KEY_recv:
4518             LOP(OP_RECV,XTERM);
4519
4520         case KEY_reverse:
4521             LOP(OP_REVERSE,XTERM);
4522
4523         case KEY_readlink:
4524             UNI(OP_READLINK);
4525
4526         case KEY_ref:
4527             UNI(OP_REF);
4528
4529         case KEY_s:
4530             s = scan_subst(s);
4531             if (yylval.opval)
4532                 TERM(sublex_start());
4533             else
4534                 TOKEN(1);       /* force error */
4535
4536         case KEY_chomp:
4537             UNI(OP_CHOMP);
4538
4539         case KEY_scalar:
4540             UNI(OP_SCALAR);
4541
4542         case KEY_select:
4543             LOP(OP_SELECT,XTERM);
4544
4545         case KEY_seek:
4546             LOP(OP_SEEK,XTERM);
4547
4548         case KEY_semctl:
4549             LOP(OP_SEMCTL,XTERM);
4550
4551         case KEY_semget:
4552             LOP(OP_SEMGET,XTERM);
4553
4554         case KEY_semop:
4555             LOP(OP_SEMOP,XTERM);
4556
4557         case KEY_send:
4558             LOP(OP_SEND,XTERM);
4559
4560         case KEY_setpgrp:
4561             LOP(OP_SETPGRP,XTERM);
4562
4563         case KEY_setpriority:
4564             LOP(OP_SETPRIORITY,XTERM);
4565
4566         case KEY_sethostent:
4567             UNI(OP_SHOSTENT);
4568
4569         case KEY_setnetent:
4570             UNI(OP_SNETENT);
4571
4572         case KEY_setservent:
4573             UNI(OP_SSERVENT);
4574
4575         case KEY_setprotoent:
4576             UNI(OP_SPROTOENT);
4577
4578         case KEY_setpwent:
4579             FUN0(OP_SPWENT);
4580
4581         case KEY_setgrent:
4582             FUN0(OP_SGRENT);
4583
4584         case KEY_seekdir:
4585             LOP(OP_SEEKDIR,XTERM);
4586
4587         case KEY_setsockopt:
4588             LOP(OP_SSOCKOPT,XTERM);
4589
4590         case KEY_shift:
4591             UNI(OP_SHIFT);
4592
4593         case KEY_shmctl:
4594             LOP(OP_SHMCTL,XTERM);
4595
4596         case KEY_shmget:
4597             LOP(OP_SHMGET,XTERM);
4598
4599         case KEY_shmread:
4600             LOP(OP_SHMREAD,XTERM);
4601
4602         case KEY_shmwrite:
4603             LOP(OP_SHMWRITE,XTERM);
4604
4605         case KEY_shutdown:
4606             LOP(OP_SHUTDOWN,XTERM);
4607
4608         case KEY_sin:
4609             UNI(OP_SIN);
4610
4611         case KEY_sleep:
4612             UNI(OP_SLEEP);
4613
4614         case KEY_socket:
4615             LOP(OP_SOCKET,XTERM);
4616
4617         case KEY_socketpair:
4618             LOP(OP_SOCKPAIR,XTERM);
4619
4620         case KEY_sort:
4621             checkcomma(s,PL_tokenbuf,"subroutine name");
4622             s = skipspace(s);
4623             if (*s == ';' || *s == ')')         /* probably a close */
4624                 Perl_croak(aTHX_ "sort is now a reserved word");
4625             PL_expect = XTERM;
4626             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4627             LOP(OP_SORT,XREF);
4628
4629         case KEY_split:
4630             LOP(OP_SPLIT,XTERM);
4631
4632         case KEY_sprintf:
4633             LOP(OP_SPRINTF,XTERM);
4634
4635         case KEY_splice:
4636             LOP(OP_SPLICE,XTERM);
4637
4638         case KEY_sqrt:
4639             UNI(OP_SQRT);
4640
4641         case KEY_srand:
4642             UNI(OP_SRAND);
4643
4644         case KEY_stat:
4645             UNI(OP_STAT);
4646
4647         case KEY_study:
4648             UNI(OP_STUDY);
4649
4650         case KEY_substr:
4651             LOP(OP_SUBSTR,XTERM);
4652
4653         case KEY_format:
4654         case KEY_sub:
4655           really_sub:
4656             {
4657                 char tmpbuf[sizeof PL_tokenbuf];
4658                 SSize_t tboffset;
4659                 expectation attrful;
4660                 bool have_name, have_proto;
4661                 int key = tmp;
4662
4663                 s = skipspace(s);
4664
4665                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4666                     (*s == ':' && s[1] == ':'))
4667                 {
4668                     PL_expect = XBLOCK;
4669                     attrful = XATTRBLOCK;
4670                     /* remember buffer pos'n for later force_word */
4671                     tboffset = s - PL_oldbufptr;
4672                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4673                     if (strchr(tmpbuf, ':'))
4674                         sv_setpv(PL_subname, tmpbuf);
4675                     else {
4676                         sv_setsv(PL_subname,PL_curstname);
4677                         sv_catpvn(PL_subname,"::",2);
4678                         sv_catpvn(PL_subname,tmpbuf,len);
4679                     }
4680                     s = skipspace(d);
4681                     have_name = TRUE;
4682                 }
4683                 else {
4684                     if (key == KEY_my)
4685                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4686                     PL_expect = XTERMBLOCK;
4687                     attrful = XATTRTERM;
4688                     sv_setpv(PL_subname,"?");
4689                     have_name = FALSE;
4690                 }
4691
4692                 if (key == KEY_format) {
4693                     if (*s == '=')
4694                         PL_lex_formbrack = PL_lex_brackets + 1;
4695                     if (have_name)
4696                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4697                                           FALSE, TRUE, TRUE);
4698                     OPERATOR(FORMAT);
4699                 }
4700
4701                 /* Look for a prototype */
4702                 if (*s == '(') {
4703                     char *p;
4704
4705                     s = scan_str(s,FALSE,FALSE);
4706                     if (!s) {
4707                         if (PL_lex_stuff)
4708                             SvREFCNT_dec(PL_lex_stuff);
4709                         PL_lex_stuff = Nullsv;
4710                         Perl_croak(aTHX_ "Prototype not terminated");
4711                     }
4712                     /* strip spaces */
4713                     d = SvPVX(PL_lex_stuff);
4714                     tmp = 0;
4715                     for (p = d; *p; ++p) {
4716                         if (!isSPACE(*p))
4717                             d[tmp++] = *p;
4718                     }
4719                     d[tmp] = '\0';
4720                     SvCUR(PL_lex_stuff) = tmp;
4721                     have_proto = TRUE;
4722
4723                     s = skipspace(s);
4724                 }
4725                 else
4726                     have_proto = FALSE;
4727
4728                 if (*s == ':' && s[1] != ':')
4729                     PL_expect = attrful;
4730
4731                 if (have_proto) {
4732                     PL_nextval[PL_nexttoke].opval =
4733                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4734                     PL_lex_stuff = Nullsv;
4735                     force_next(THING);
4736                 }
4737                 if (!have_name) {
4738                     sv_setpv(PL_subname,"__ANON__");
4739                     TOKEN(ANONSUB);
4740                 }
4741                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4742                                   FALSE, TRUE, TRUE);
4743                 if (key == KEY_my)
4744                     TOKEN(MYSUB);
4745                 TOKEN(SUB);
4746             }
4747
4748         case KEY_system:
4749             set_csh();
4750             LOP(OP_SYSTEM,XREF);
4751
4752         case KEY_symlink:
4753             LOP(OP_SYMLINK,XTERM);
4754
4755         case KEY_syscall:
4756             LOP(OP_SYSCALL,XTERM);
4757
4758         case KEY_sysopen:
4759             LOP(OP_SYSOPEN,XTERM);
4760
4761         case KEY_sysseek:
4762             LOP(OP_SYSSEEK,XTERM);
4763
4764         case KEY_sysread:
4765             LOP(OP_SYSREAD,XTERM);
4766
4767         case KEY_syswrite:
4768             LOP(OP_SYSWRITE,XTERM);
4769
4770         case KEY_tr:
4771             s = scan_trans(s);
4772             TERM(sublex_start());
4773
4774         case KEY_tell:
4775             UNI(OP_TELL);
4776
4777         case KEY_telldir:
4778             UNI(OP_TELLDIR);
4779
4780         case KEY_tie:
4781             LOP(OP_TIE,XTERM);
4782
4783         case KEY_tied:
4784             UNI(OP_TIED);
4785
4786         case KEY_time:
4787             FUN0(OP_TIME);
4788
4789         case KEY_times:
4790             FUN0(OP_TMS);
4791
4792         case KEY_truncate:
4793             LOP(OP_TRUNCATE,XTERM);
4794
4795         case KEY_uc:
4796             UNI(OP_UC);
4797
4798         case KEY_ucfirst:
4799             UNI(OP_UCFIRST);
4800
4801         case KEY_untie:
4802             UNI(OP_UNTIE);
4803
4804         case KEY_until:
4805             yylval.ival = CopLINE(PL_curcop);
4806             OPERATOR(UNTIL);
4807
4808         case KEY_unless:
4809             yylval.ival = CopLINE(PL_curcop);
4810             OPERATOR(UNLESS);
4811
4812         case KEY_unlink:
4813             LOP(OP_UNLINK,XTERM);
4814
4815         case KEY_undef:
4816             UNI(OP_UNDEF);
4817
4818         case KEY_unpack:
4819             LOP(OP_UNPACK,XTERM);
4820
4821         case KEY_utime:
4822             LOP(OP_UTIME,XTERM);
4823
4824         case KEY_umask:
4825             if (ckWARN(WARN_UMASK)) {
4826                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4827                 if (*d != '0' && isDIGIT(*d))
4828                     Perl_warner(aTHX_ WARN_UMASK,
4829                                 "umask: argument is missing initial 0");
4830             }
4831             UNI(OP_UMASK);
4832
4833         case KEY_unshift:
4834             LOP(OP_UNSHIFT,XTERM);
4835
4836         case KEY_use:
4837             if (PL_expect != XSTATE)
4838                 yyerror("\"use\" not allowed in expression");
4839             s = skipspace(s);
4840             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4841                 s = force_version(s);
4842                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4843                     PL_nextval[PL_nexttoke].opval = Nullop;
4844                     force_next(WORD);
4845                 }
4846             }
4847             else {
4848                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4849                 s = force_version(s);
4850             }
4851             yylval.ival = 1;
4852             OPERATOR(USE);
4853
4854         case KEY_values:
4855             UNI(OP_VALUES);
4856
4857         case KEY_vec:
4858             LOP(OP_VEC,XTERM);
4859
4860         case KEY_while:
4861             yylval.ival = CopLINE(PL_curcop);
4862             OPERATOR(WHILE);
4863
4864         case KEY_warn:
4865             PL_hints |= HINT_BLOCK_SCOPE;
4866             LOP(OP_WARN,XTERM);
4867
4868         case KEY_wait:
4869             FUN0(OP_WAIT);
4870
4871         case KEY_waitpid:
4872             LOP(OP_WAITPID,XTERM);
4873
4874         case KEY_wantarray:
4875             FUN0(OP_WANTARRAY);
4876
4877         case KEY_write:
4878 #ifdef EBCDIC
4879         {
4880             static char ctl_l[2];
4881
4882             if (ctl_l[0] == '\0')
4883                 ctl_l[0] = toCTRL('L');
4884             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4885         }
4886 #else
4887             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4888 #endif
4889             UNI(OP_ENTERWRITE);
4890
4891         case KEY_x:
4892             if (PL_expect == XOPERATOR)
4893                 Mop(OP_REPEAT);
4894             check_uni();
4895             goto just_a_word;
4896
4897         case KEY_xor:
4898             yylval.ival = OP_XOR;
4899             OPERATOR(OROP);
4900
4901         case KEY_y:
4902             s = scan_trans(s);
4903             TERM(sublex_start());
4904         }
4905     }}
4906 }
4907
4908 I32
4909 Perl_keyword(pTHX_ register char *d, I32 len)
4910 {
4911     switch (*d) {
4912     case '_':
4913         if (d[1] == '_') {
4914             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4915             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4916             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4917             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4918             if (strEQ(d,"__END__"))             return KEY___END__;
4919         }
4920         break;
4921     case 'A':
4922         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4923         break;
4924     case 'a':
4925         switch (len) {
4926         case 3:
4927             if (strEQ(d,"and"))                 return -KEY_and;
4928             if (strEQ(d,"abs"))                 return -KEY_abs;
4929             break;
4930         case 5:
4931             if (strEQ(d,"alarm"))               return -KEY_alarm;
4932             if (strEQ(d,"atan2"))               return -KEY_atan2;
4933             break;
4934         case 6:
4935             if (strEQ(d,"accept"))              return -KEY_accept;
4936             break;
4937         }
4938         break;
4939     case 'B':
4940         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4941         break;
4942     case 'b':
4943         if (strEQ(d,"bless"))                   return -KEY_bless;
4944         if (strEQ(d,"bind"))                    return -KEY_bind;
4945         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4946         break;
4947     case 'C':
4948         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4949         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
4950         break;
4951     case 'c':
4952         switch (len) {
4953         case 3:
4954             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4955             if (strEQ(d,"chr"))                 return -KEY_chr;
4956             if (strEQ(d,"cos"))                 return -KEY_cos;
4957             break;
4958         case 4:
4959             if (strEQ(d,"chop"))                return KEY_chop;
4960             break;
4961         case 5:
4962             if (strEQ(d,"close"))               return -KEY_close;
4963             if (strEQ(d,"chdir"))               return -KEY_chdir;
4964             if (strEQ(d,"chomp"))               return KEY_chomp;
4965             if (strEQ(d,"chmod"))               return -KEY_chmod;
4966             if (strEQ(d,"chown"))               return -KEY_chown;
4967             if (strEQ(d,"crypt"))               return -KEY_crypt;
4968             break;
4969         case 6:
4970             if (strEQ(d,"chroot"))              return -KEY_chroot;
4971             if (strEQ(d,"caller"))              return -KEY_caller;
4972             break;
4973         case 7:
4974             if (strEQ(d,"connect"))             return -KEY_connect;
4975             break;
4976         case 8:
4977             if (strEQ(d,"closedir"))            return -KEY_closedir;
4978             if (strEQ(d,"continue"))            return -KEY_continue;
4979             break;
4980         }
4981         break;
4982     case 'D':
4983         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4984         break;
4985     case 'd':
4986         switch (len) {
4987         case 2:
4988             if (strEQ(d,"do"))                  return KEY_do;
4989             break;
4990         case 3:
4991             if (strEQ(d,"die"))                 return -KEY_die;
4992             break;
4993         case 4:
4994             if (strEQ(d,"dump"))                return -KEY_dump;
4995             break;
4996         case 6:
4997             if (strEQ(d,"delete"))              return KEY_delete;
4998             break;
4999         case 7:
5000             if (strEQ(d,"defined"))             return KEY_defined;
5001             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5002             break;
5003         case 8:
5004             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5005             break;
5006         }
5007         break;
5008     case 'E':
5009         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
5010         if (strEQ(d,"END"))                     return KEY_END;
5011         break;
5012     case 'e':
5013         switch (len) {
5014         case 2:
5015             if (strEQ(d,"eq"))                  return -KEY_eq;
5016             break;
5017         case 3:
5018             if (strEQ(d,"eof"))                 return -KEY_eof;
5019             if (strEQ(d,"exp"))                 return -KEY_exp;
5020             break;
5021         case 4:
5022             if (strEQ(d,"else"))                return KEY_else;
5023             if (strEQ(d,"exit"))                return -KEY_exit;
5024             if (strEQ(d,"eval"))                return KEY_eval;
5025             if (strEQ(d,"exec"))                return -KEY_exec;
5026             if (strEQ(d,"each"))                return KEY_each;
5027             break;
5028         case 5:
5029             if (strEQ(d,"elsif"))               return KEY_elsif;
5030             break;
5031         case 6:
5032             if (strEQ(d,"exists"))              return KEY_exists;
5033             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5034             break;
5035         case 8:
5036             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5037             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5038             break;
5039         case 9:
5040             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5041             break;
5042         case 10:
5043             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5044             if (strEQ(d,"endservent"))          return -KEY_endservent;
5045             break;
5046         case 11:
5047             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5048             break;
5049         }
5050         break;
5051     case 'f':
5052         switch (len) {
5053         case 3:
5054             if (strEQ(d,"for"))                 return KEY_for;
5055             break;
5056         case 4:
5057             if (strEQ(d,"fork"))                return -KEY_fork;
5058             break;
5059         case 5:
5060             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5061             if (strEQ(d,"flock"))               return -KEY_flock;
5062             break;
5063         case 6:
5064             if (strEQ(d,"format"))              return KEY_format;
5065             if (strEQ(d,"fileno"))              return -KEY_fileno;
5066             break;
5067         case 7:
5068             if (strEQ(d,"foreach"))             return KEY_foreach;
5069             break;
5070         case 8:
5071             if (strEQ(d,"formline"))            return -KEY_formline;
5072             break;
5073         }
5074         break;
5075     case 'G':
5076         if (len == 2) {
5077             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
5078             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
5079         }
5080         break;
5081     case 'g':
5082         if (strnEQ(d,"get",3)) {
5083             d += 3;
5084             if (*d == 'p') {
5085                 switch (len) {
5086                 case 7:
5087                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5088                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5089                     break;
5090                 case 8:
5091                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5092                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5093                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5094                     break;
5095                 case 11:
5096                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5097                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5098                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5099                     break;
5100                 case 14:
5101                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5102                     break;
5103                 case 16:
5104                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5105                     break;
5106                 }
5107             }
5108             else if (*d == 'h') {
5109                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5110                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5111                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5112             }
5113             else if (*d == 'n') {
5114                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5115                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5116                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5117             }
5118             else if (*d == 's') {
5119                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5120                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5121                 if (strEQ(d,"servent"))         return -KEY_getservent;
5122                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5123                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5124             }
5125             else if (*d == 'g') {
5126                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5127                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5128                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5129             }
5130             else if (*d == 'l') {
5131                 if (strEQ(d,"login"))           return -KEY_getlogin;
5132             }
5133             else if (strEQ(d,"c"))              return -KEY_getc;
5134             break;
5135         }
5136         switch (len) {
5137         case 2:
5138             if (strEQ(d,"gt"))                  return -KEY_gt;
5139             if (strEQ(d,"ge"))                  return -KEY_ge;
5140             break;
5141         case 4:
5142             if (strEQ(d,"grep"))                return KEY_grep;
5143             if (strEQ(d,"goto"))                return KEY_goto;
5144             if (strEQ(d,"glob"))                return KEY_glob;
5145             break;
5146         case 6:
5147             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5148             break;
5149         }
5150         break;
5151     case 'h':
5152         if (strEQ(d,"hex"))                     return -KEY_hex;
5153         break;
5154     case 'I':
5155         if (strEQ(d,"INIT"))                    return KEY_INIT;
5156         break;
5157     case 'i':
5158         switch (len) {
5159         case 2:
5160             if (strEQ(d,"if"))                  return KEY_if;
5161             break;
5162         case 3:
5163             if (strEQ(d,"int"))                 return -KEY_int;
5164             break;
5165         case 5:
5166             if (strEQ(d,"index"))               return -KEY_index;
5167             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5168             break;
5169         }
5170         break;
5171     case 'j':
5172         if (strEQ(d,"join"))                    return -KEY_join;
5173         break;
5174     case 'k':
5175         if (len == 4) {
5176             if (strEQ(d,"keys"))                return KEY_keys;
5177             if (strEQ(d,"kill"))                return -KEY_kill;
5178         }
5179         break;
5180     case 'L':
5181         if (len == 2) {
5182             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
5183             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
5184         }
5185         break;
5186     case 'l':
5187         switch (len) {
5188         case 2:
5189             if (strEQ(d,"lt"))                  return -KEY_lt;
5190             if (strEQ(d,"le"))                  return -KEY_le;
5191             if (strEQ(d,"lc"))                  return -KEY_lc;
5192             break;
5193         case 3:
5194             if (strEQ(d,"log"))                 return -KEY_log;
5195             break;
5196         case 4:
5197             if (strEQ(d,"last"))                return KEY_last;
5198             if (strEQ(d,"link"))                return -KEY_link;
5199             if (strEQ(d,"lock"))                return -KEY_lock;
5200             break;
5201         case 5:
5202             if (strEQ(d,"local"))               return KEY_local;
5203             if (strEQ(d,"lstat"))               return -KEY_lstat;
5204             break;
5205         case 6:
5206             if (strEQ(d,"length"))              return -KEY_length;
5207             if (strEQ(d,"listen"))              return -KEY_listen;
5208             break;
5209         case 7:
5210             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5211             break;
5212         case 9:
5213             if (strEQ(d,"localtime"))           return -KEY_localtime;
5214             break;
5215         }
5216         break;
5217     case 'm':
5218         switch (len) {
5219         case 1:                                 return KEY_m;
5220         case 2:
5221             if (strEQ(d,"my"))                  return KEY_my;
5222             break;
5223         case 3:
5224             if (strEQ(d,"map"))                 return KEY_map;
5225             break;
5226         case 5:
5227             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5228             break;
5229         case 6:
5230             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5231             if (strEQ(d,"msgget"))              return -KEY_msgget;
5232             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5233             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5234             break;
5235         }
5236         break;
5237     case 'N':
5238         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
5239         break;
5240     case 'n':
5241         if (strEQ(d,"next"))                    return KEY_next;
5242         if (strEQ(d,"ne"))                      return -KEY_ne;
5243         if (strEQ(d,"not"))                     return -KEY_not;
5244         if (strEQ(d,"no"))                      return KEY_no;
5245         break;
5246     case 'o':
5247         switch (len) {
5248         case 2:
5249             if (strEQ(d,"or"))                  return -KEY_or;
5250             break;
5251         case 3:
5252             if (strEQ(d,"ord"))                 return -KEY_ord;
5253             if (strEQ(d,"oct"))                 return -KEY_oct;
5254             if (strEQ(d,"our"))                 return KEY_our;
5255             break;
5256         case 4:
5257             if (strEQ(d,"open"))                return -KEY_open;
5258             break;
5259         case 7:
5260             if (strEQ(d,"opendir"))             return -KEY_opendir;
5261             break;
5262         }
5263         break;
5264     case 'p':
5265         switch (len) {
5266         case 3:
5267             if (strEQ(d,"pop"))                 return KEY_pop;
5268             if (strEQ(d,"pos"))                 return KEY_pos;
5269             break;
5270         case 4:
5271             if (strEQ(d,"push"))                return KEY_push;
5272             if (strEQ(d,"pack"))                return -KEY_pack;
5273             if (strEQ(d,"pipe"))                return -KEY_pipe;
5274             break;
5275         case 5:
5276             if (strEQ(d,"print"))               return KEY_print;
5277             break;
5278         case 6:
5279             if (strEQ(d,"printf"))              return KEY_printf;
5280             break;
5281         case 7:
5282             if (strEQ(d,"package"))             return KEY_package;
5283             break;
5284         case 9:
5285             if (strEQ(d,"prototype"))           return KEY_prototype;
5286         }
5287         break;
5288     case 'q':
5289         if (len <= 2) {
5290             if (strEQ(d,"q"))                   return KEY_q;
5291             if (strEQ(d,"qr"))                  return KEY_qr;
5292             if (strEQ(d,"qq"))                  return KEY_qq;
5293             if (strEQ(d,"qw"))                  return KEY_qw;
5294             if (strEQ(d,"qx"))                  return KEY_qx;
5295         }
5296         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5297         break;
5298     case 'r':
5299         switch (len) {
5300         case 3:
5301             if (strEQ(d,"ref"))                 return -KEY_ref;
5302             break;
5303         case 4:
5304             if (strEQ(d,"read"))                return -KEY_read;
5305             if (strEQ(d,"rand"))                return -KEY_rand;
5306             if (strEQ(d,"recv"))                return -KEY_recv;
5307             if (strEQ(d,"redo"))                return KEY_redo;
5308             break;
5309         case 5:
5310             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5311             if (strEQ(d,"reset"))               return -KEY_reset;
5312             break;
5313         case 6:
5314             if (strEQ(d,"return"))              return KEY_return;
5315             if (strEQ(d,"rename"))              return -KEY_rename;
5316             if (strEQ(d,"rindex"))              return -KEY_rindex;
5317             break;
5318         case 7:
5319             if (strEQ(d,"require"))             return -KEY_require;
5320             if (strEQ(d,"reverse"))             return -KEY_reverse;
5321             if (strEQ(d,"readdir"))             return -KEY_readdir;
5322             break;
5323         case 8:
5324             if (strEQ(d,"readlink"))            return -KEY_readlink;
5325             if (strEQ(d,"readline"))            return -KEY_readline;
5326             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5327             break;
5328         case 9:
5329             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5330             break;
5331         }
5332         break;
5333     case 's':
5334         switch (d[1]) {
5335         case 0:                                 return KEY_s;
5336         case 'c':
5337             if (strEQ(d,"scalar"))              return KEY_scalar;
5338             break;
5339         case 'e':
5340             switch (len) {
5341             case 4:
5342                 if (strEQ(d,"seek"))            return -KEY_seek;
5343                 if (strEQ(d,"send"))            return -KEY_send;
5344                 break;
5345             case 5:
5346                 if (strEQ(d,"semop"))           return -KEY_semop;
5347                 break;
5348             case 6:
5349                 if (strEQ(d,"select"))          return -KEY_select;
5350                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5351                 if (strEQ(d,"semget"))          return -KEY_semget;
5352                 break;
5353             case 7:
5354                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5355                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5356                 break;
5357             case 8:
5358                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5359                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5360                 break;
5361             case 9:
5362                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5363                 break;
5364             case 10:
5365                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5366                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5367                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5368                 break;
5369             case 11:
5370                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5371                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5372                 break;
5373             }
5374             break;
5375         case 'h':
5376             switch (len) {
5377             case 5:
5378                 if (strEQ(d,"shift"))           return KEY_shift;
5379                 break;
5380             case 6:
5381                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5382                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5383                 break;
5384             case 7:
5385                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5386                 break;
5387             case 8:
5388                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5389                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5390                 break;
5391             }
5392             break;
5393         case 'i':
5394             if (strEQ(d,"sin"))                 return -KEY_sin;
5395             break;
5396         case 'l':
5397             if (strEQ(d,"sleep"))               return -KEY_sleep;
5398             break;
5399         case 'o':
5400             if (strEQ(d,"sort"))                return KEY_sort;
5401             if (strEQ(d,"socket"))              return -KEY_socket;
5402             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5403             break;
5404         case 'p':
5405             if (strEQ(d,"split"))               return KEY_split;
5406             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5407             if (strEQ(d,"splice"))              return KEY_splice;
5408             break;
5409         case 'q':
5410             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5411             break;
5412         case 'r':
5413             if (strEQ(d,"srand"))               return -KEY_srand;
5414             break;
5415         case 't':
5416             if (strEQ(d,"stat"))                return -KEY_stat;
5417             if (strEQ(d,"study"))               return KEY_study;
5418             break;
5419         case 'u':
5420             if (strEQ(d,"substr"))              return -KEY_substr;
5421             if (strEQ(d,"sub"))                 return KEY_sub;
5422             break;
5423         case 'y':
5424             switch (len) {
5425             case 6:
5426                 if (strEQ(d,"system"))          return -KEY_system;
5427                 break;
5428             case 7:
5429                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5430                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5431                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5432                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5433                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5434                 break;
5435             case 8:
5436                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5437                 break;
5438             }
5439             break;
5440         }
5441         break;
5442     case 't':
5443         switch (len) {
5444         case 2:
5445             if (strEQ(d,"tr"))                  return KEY_tr;
5446             break;
5447         case 3:
5448             if (strEQ(d,"tie"))                 return KEY_tie;
5449             break;
5450         case 4:
5451             if (strEQ(d,"tell"))                return -KEY_tell;
5452             if (strEQ(d,"tied"))                return KEY_tied;
5453             if (strEQ(d,"time"))                return -KEY_time;
5454             break;
5455         case 5:
5456             if (strEQ(d,"times"))               return -KEY_times;
5457             break;
5458         case 7:
5459             if (strEQ(d,"telldir"))             return -KEY_telldir;
5460             break;
5461         case 8:
5462             if (strEQ(d,"truncate"))            return -KEY_truncate;
5463             break;
5464         }
5465         break;
5466     case 'u':
5467         switch (len) {
5468         case 2:
5469             if (strEQ(d,"uc"))                  return -KEY_uc;
5470             break;
5471         case 3:
5472             if (strEQ(d,"use"))                 return KEY_use;
5473             break;
5474         case 5:
5475             if (strEQ(d,"undef"))               return KEY_undef;
5476             if (strEQ(d,"until"))               return KEY_until;
5477             if (strEQ(d,"untie"))               return KEY_untie;
5478             if (strEQ(d,"utime"))               return -KEY_utime;
5479             if (strEQ(d,"umask"))               return -KEY_umask;
5480             break;
5481         case 6:
5482             if (strEQ(d,"unless"))              return KEY_unless;
5483             if (strEQ(d,"unpack"))              return -KEY_unpack;
5484             if (strEQ(d,"unlink"))              return -KEY_unlink;
5485             break;
5486         case 7:
5487             if (strEQ(d,"unshift"))             return KEY_unshift;
5488             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5489             break;
5490         }
5491         break;
5492     case 'v':
5493         if (strEQ(d,"values"))                  return -KEY_values;
5494         if (strEQ(d,"vec"))                     return -KEY_vec;
5495         break;
5496     case 'w':
5497         switch (len) {
5498         case 4:
5499             if (strEQ(d,"warn"))                return -KEY_warn;
5500             if (strEQ(d,"wait"))                return -KEY_wait;
5501             break;
5502         case 5:
5503             if (strEQ(d,"while"))               return KEY_while;
5504             if (strEQ(d,"write"))               return -KEY_write;
5505             break;
5506         case 7:
5507             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5508             break;
5509         case 9:
5510             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5511             break;
5512         }
5513         break;
5514     case 'x':
5515         if (len == 1)                           return -KEY_x;
5516         if (strEQ(d,"xor"))                     return -KEY_xor;
5517         break;
5518     case 'y':
5519         if (len == 1)                           return KEY_y;
5520         break;
5521     case 'z':
5522         break;
5523     }
5524     return 0;
5525 }
5526
5527 STATIC void
5528 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5529 {
5530     char *w;
5531
5532     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5533         dTHR;                           /* only for ckWARN */
5534         if (ckWARN(WARN_SYNTAX)) {
5535             int level = 1;
5536             for (w = s+2; *w && level; w++) {
5537                 if (*w == '(')
5538                     ++level;
5539                 else if (*w == ')')
5540                     --level;
5541             }
5542             if (*w)
5543                 for (; *w && isSPACE(*w); w++) ;
5544             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5545                 Perl_warner(aTHX_ WARN_SYNTAX,
5546                             "%s (...) interpreted as function",name);
5547         }
5548     }
5549     while (s < PL_bufend && isSPACE(*s))
5550         s++;
5551     if (*s == '(')
5552         s++;
5553     while (s < PL_bufend && isSPACE(*s))
5554         s++;
5555     if (isIDFIRST_lazy_if(s,UTF)) {
5556         w = s++;
5557         while (isALNUM_lazy_if(s,UTF))
5558             s++;
5559         while (s < PL_bufend && isSPACE(*s))
5560             s++;
5561         if (*s == ',') {
5562             int kw;
5563             *s = '\0';
5564             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5565             *s = ',';
5566             if (kw)
5567                 return;
5568             Perl_croak(aTHX_ "No comma allowed after %s", what);
5569         }
5570     }
5571 }
5572
5573 /* Either returns sv, or mortalizes sv and returns a new SV*.
5574    Best used as sv=new_constant(..., sv, ...).
5575    If s, pv are NULL, calls subroutine with one argument,
5576    and type is used with error messages only. */
5577
5578 STATIC SV *
5579 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5580                const char *type)
5581 {
5582     dSP;
5583     HV *table = GvHV(PL_hintgv);                 /* ^H */
5584     SV *res;
5585     SV **cvp;
5586     SV *cv, *typesv;
5587     const char *why, *why1, *why2;
5588
5589     if (!(PL_hints & HINT_LOCALIZE_HH)) {
5590         SV *msg;
5591
5592         why = "%^H is not localized";
5593     report_short:
5594         why1 = why2 = "";
5595     report:
5596         msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s",
5597                             (type ? type: "undef"), why1, why2, why);
5598         yyerror(SvPVX(msg));
5599         SvREFCNT_dec(msg);
5600         return sv;
5601     }
5602     if (!table) {
5603         why = "%^H is not defined";
5604         goto report_short;
5605     }
5606     cvp = hv_fetch(table, key, strlen(key), FALSE);
5607     if (!cvp || !SvOK(*cvp)) {
5608         why = "} is not defined";
5609         why1 = "$^H{";
5610         why2 = key;
5611         goto report;
5612     }
5613     sv_2mortal(sv);                     /* Parent created it permanently */
5614     cv = *cvp;
5615     if (!pv && s)
5616         pv = sv_2mortal(newSVpvn(s, len));
5617     if (type && pv)
5618         typesv = sv_2mortal(newSVpv(type, 0));
5619     else
5620         typesv = &PL_sv_undef;
5621
5622     PUSHSTACKi(PERLSI_OVERLOAD);
5623     ENTER ;
5624     SAVETMPS;
5625
5626     PUSHMARK(SP) ;
5627     EXTEND(sp, 4);
5628     if (pv)
5629         PUSHs(pv);
5630     PUSHs(sv);
5631     if (pv)
5632         PUSHs(typesv);
5633     PUSHs(cv);
5634     PUTBACK;
5635     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5636
5637     SPAGAIN ;
5638
5639     /* Check the eval first */
5640     if (!PL_in_eval && SvTRUE(ERRSV))
5641     {
5642         STRLEN n_a;
5643         sv_catpv(ERRSV, "Propagated");
5644         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5645         (void)POPs;
5646         res = SvREFCNT_inc(sv);
5647     }
5648     else {
5649         res = POPs;
5650         (void)SvREFCNT_inc(res);
5651     }
5652
5653     PUTBACK ;
5654     FREETMPS ;
5655     LEAVE ;
5656     POPSTACK;
5657
5658     if (!SvOK(res)) {
5659         why = "}} did not return a defined value";
5660         why1 = "Call to &{$^H{";
5661         why2 = key;
5662         sv = res;
5663         goto report;
5664      }
5665
5666      return res;
5667 }
5668
5669 STATIC char *
5670 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5671 {
5672     register char *d = dest;
5673     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5674     for (;;) {
5675         if (d >= e)
5676             Perl_croak(aTHX_ ident_too_long);
5677         if (isALNUM(*s))        /* UTF handled below */
5678             *d++ = *s++;
5679         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
5680             *d++ = ':';
5681             *d++ = ':';
5682             s++;
5683         }
5684         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5685             *d++ = *s++;
5686             *d++ = *s++;
5687         }
5688         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5689             char *t = s + UTF8SKIP(s);
5690             while (*t & 0x80 && is_utf8_mark((U8*)t))
5691                 t += UTF8SKIP(t);
5692             if (d + (t - s) > e)
5693                 Perl_croak(aTHX_ ident_too_long);
5694             Copy(s, d, t - s, char);
5695             d += t - s;
5696             s = t;
5697         }
5698         else {
5699             *d = '\0';
5700             *slp = d - dest;
5701             return s;
5702         }
5703     }
5704 }
5705
5706 STATIC char *
5707 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5708 {
5709     register char *d;
5710     register char *e;
5711     char *bracket = 0;
5712     char funny = *s++;
5713
5714     if (isSPACE(*s))
5715         s = skipspace(s);
5716     d = dest;
5717     e = d + destlen - 3;        /* two-character token, ending NUL */
5718     if (isDIGIT(*s)) {
5719         while (isDIGIT(*s)) {
5720             if (d >= e)
5721                 Perl_croak(aTHX_ ident_too_long);
5722             *d++ = *s++;
5723         }
5724     }
5725     else {
5726         for (;;) {
5727             if (d >= e)
5728                 Perl_croak(aTHX_ ident_too_long);
5729             if (isALNUM(*s))    /* UTF handled below */
5730                 *d++ = *s++;
5731             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
5732                 *d++ = ':';
5733                 *d++ = ':';
5734                 s++;
5735             }
5736             else if (*s == ':' && s[1] == ':') {
5737                 *d++ = *s++;
5738                 *d++ = *s++;
5739             }
5740             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5741                 char *t = s + UTF8SKIP(s);
5742                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5743                     t += UTF8SKIP(t);
5744                 if (d + (t - s) > e)
5745                     Perl_croak(aTHX_ ident_too_long);
5746                 Copy(s, d, t - s, char);
5747                 d += t - s;
5748                 s = t;
5749             }
5750             else
5751                 break;
5752         }
5753     }
5754     *d = '\0';
5755     d = dest;
5756     if (*d) {
5757         if (PL_lex_state != LEX_NORMAL)
5758             PL_lex_state = LEX_INTERPENDMAYBE;
5759         return s;
5760     }
5761     if (*s == '$' && s[1] &&
5762         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5763     {
5764         return s;
5765     }
5766     if (*s == '{') {
5767         bracket = s;
5768         s++;
5769     }
5770     else if (ck_uni)
5771         check_uni();
5772     if (s < send)
5773         *d = *s++;
5774     d[1] = '\0';
5775     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5776         *d = toCTRL(*s);
5777         s++;
5778     }
5779     if (bracket) {
5780         if (isSPACE(s[-1])) {
5781             while (s < send) {
5782                 char ch = *s++;
5783                 if (ch != ' ' && ch != '\t') {
5784                     *d = ch;
5785                     break;
5786                 }
5787             }
5788         }
5789         if (isIDFIRST_lazy_if(d,UTF)) {
5790             d++;
5791             if (UTF) {
5792                 e = s;
5793                 while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') {
5794                     e += UTF8SKIP(e);
5795                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5796                         e += UTF8SKIP(e);
5797                 }
5798                 Copy(s, d, e - s, char);
5799                 d += e - s;
5800                 s = e;
5801             }
5802             else {
5803                 while ((isALNUM(*s) || *s == ':') && d < e)
5804                     *d++ = *s++;
5805                 if (d >= e)
5806                     Perl_croak(aTHX_ ident_too_long);
5807             }
5808             *d = '\0';
5809             while (s < send && (*s == ' ' || *s == '\t')) s++;
5810             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5811                 dTHR;                   /* only for ckWARN */
5812                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5813                     const char *brack = *s == '[' ? "[...]" : "{...}";
5814                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5815                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5816                         funny, dest, brack, funny, dest, brack);
5817                 }
5818                 bracket++;
5819                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
5820                 return s;
5821             }
5822         }
5823         /* Handle extended ${^Foo} variables
5824          * 1999-02-27 mjd-perl-patch@plover.com */
5825         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5826                  && isALNUM(*s))
5827         {
5828             d++;
5829             while (isALNUM(*s) && d < e) {
5830                 *d++ = *s++;
5831             }
5832             if (d >= e)
5833                 Perl_croak(aTHX_ ident_too_long);
5834             *d = '\0';
5835         }
5836         if (*s == '}') {
5837             s++;
5838             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5839                 PL_lex_state = LEX_INTERPEND;
5840             if (funny == '#')
5841                 funny = '@';
5842             if (PL_lex_state == LEX_NORMAL) {
5843                 dTHR;                   /* only for ckWARN */
5844                 if (ckWARN(WARN_AMBIGUOUS) &&
5845                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5846                 {
5847                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5848                         "Ambiguous use of %c{%s} resolved to %c%s",
5849                         funny, dest, funny, dest);
5850                 }
5851             }
5852         }
5853         else {
5854             s = bracket;                /* let the parser handle it */
5855             *dest = '\0';
5856         }
5857     }
5858     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5859         PL_lex_state = LEX_INTERPEND;
5860     return s;
5861 }
5862
5863 void
5864 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5865 {
5866     if (ch == 'i')
5867         *pmfl |= PMf_FOLD;
5868     else if (ch == 'g')
5869         *pmfl |= PMf_GLOBAL;
5870     else if (ch == 'c')
5871         *pmfl |= PMf_CONTINUE;
5872     else if (ch == 'o')
5873         *pmfl |= PMf_KEEP;
5874     else if (ch == 'm')
5875         *pmfl |= PMf_MULTILINE;
5876     else if (ch == 's')
5877         *pmfl |= PMf_SINGLELINE;
5878     else if (ch == 'x')
5879         *pmfl |= PMf_EXTENDED;
5880 }
5881
5882 STATIC char *
5883 S_scan_pat(pTHX_ char *start, I32 type)
5884 {
5885     PMOP *pm;
5886     char *s;
5887
5888     s = scan_str(start,FALSE,FALSE);
5889     if (!s) {
5890         if (PL_lex_stuff)
5891             SvREFCNT_dec(PL_lex_stuff);
5892         PL_lex_stuff = Nullsv;
5893         Perl_croak(aTHX_ "Search pattern not terminated");
5894     }
5895
5896     pm = (PMOP*)newPMOP(type, 0);
5897     if (PL_multi_open == '?')
5898         pm->op_pmflags |= PMf_ONCE;
5899     if(type == OP_QR) {
5900         while (*s && strchr("iomsx", *s))
5901             pmflag(&pm->op_pmflags,*s++);
5902     }
5903     else {
5904         while (*s && strchr("iogcmsx", *s))
5905             pmflag(&pm->op_pmflags,*s++);
5906     }
5907     pm->op_pmpermflags = pm->op_pmflags;
5908
5909     PL_lex_op = (OP*)pm;
5910     yylval.ival = OP_MATCH;
5911     return s;
5912 }
5913
5914 STATIC char *
5915 S_scan_subst(pTHX_ char *start)
5916 {
5917     register char *s;
5918     register PMOP *pm;
5919     I32 first_start;
5920     I32 es = 0;
5921
5922     yylval.ival = OP_NULL;
5923
5924     s = scan_str(start,FALSE,FALSE);
5925
5926     if (!s) {
5927         if (PL_lex_stuff)
5928             SvREFCNT_dec(PL_lex_stuff);
5929         PL_lex_stuff = Nullsv;
5930         Perl_croak(aTHX_ "Substitution pattern not terminated");
5931     }
5932
5933     if (s[-1] == PL_multi_open)
5934         s--;
5935
5936     first_start = PL_multi_start;
5937     s = scan_str(s,FALSE,FALSE);
5938     if (!s) {
5939         if (PL_lex_stuff)
5940             SvREFCNT_dec(PL_lex_stuff);
5941         PL_lex_stuff = Nullsv;
5942         if (PL_lex_repl)
5943             SvREFCNT_dec(PL_lex_repl);
5944         PL_lex_repl = Nullsv;
5945         Perl_croak(aTHX_ "Substitution replacement not terminated");
5946     }
5947     PL_multi_start = first_start;       /* so whole substitution is taken together */
5948
5949     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5950     while (*s) {
5951         if (*s == 'e') {
5952             s++;
5953             es++;
5954         }
5955         else if (strchr("iogcmsx", *s))
5956             pmflag(&pm->op_pmflags,*s++);
5957         else
5958             break;
5959     }
5960
5961     if (es) {
5962         SV *repl;
5963         PL_sublex_info.super_bufptr = s;
5964         PL_sublex_info.super_bufend = PL_bufend;
5965         PL_multi_end = 0;
5966         pm->op_pmflags |= PMf_EVAL;
5967         repl = newSVpvn("",0);
5968         while (es-- > 0)
5969             sv_catpv(repl, es ? "eval " : "do ");
5970         sv_catpvn(repl, "{ ", 2);
5971         sv_catsv(repl, PL_lex_repl);
5972         sv_catpvn(repl, " };", 2);
5973         SvEVALED_on(repl);
5974         SvREFCNT_dec(PL_lex_repl);
5975         PL_lex_repl = repl;
5976     }
5977
5978     pm->op_pmpermflags = pm->op_pmflags;
5979     PL_lex_op = (OP*)pm;
5980     yylval.ival = OP_SUBST;
5981     return s;
5982 }
5983
5984 STATIC char *
5985 S_scan_trans(pTHX_ char *start)
5986 {
5987     register char* s;
5988     OP *o;
5989     short *tbl;
5990     I32 squash;
5991     I32 del;
5992     I32 complement;
5993     I32 utf8;
5994     I32 count = 0;
5995
5996     yylval.ival = OP_NULL;
5997
5998     s = scan_str(start,FALSE,FALSE);
5999     if (!s) {
6000         if (PL_lex_stuff)
6001             SvREFCNT_dec(PL_lex_stuff);
6002         PL_lex_stuff = Nullsv;
6003         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6004     }
6005     if (s[-1] == PL_multi_open)
6006         s--;
6007
6008     s = scan_str(s,FALSE,FALSE);
6009     if (!s) {
6010         if (PL_lex_stuff)
6011             SvREFCNT_dec(PL_lex_stuff);
6012         PL_lex_stuff = Nullsv;
6013         if (PL_lex_repl)
6014             SvREFCNT_dec(PL_lex_repl);
6015         PL_lex_repl = Nullsv;
6016         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6017     }
6018
6019     if (UTF) {
6020         o = newSVOP(OP_TRANS, 0, 0);
6021         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
6022     }
6023     else {
6024         New(803,tbl,256,short);
6025         o = newPVOP(OP_TRANS, 0, (char*)tbl);
6026         utf8 = 0;
6027     }
6028
6029     complement = del = squash = 0;
6030     while (strchr("cdsCU", *s)) {
6031         if (*s == 'c')
6032             complement = OPpTRANS_COMPLEMENT;
6033         else if (*s == 'd')
6034             del = OPpTRANS_DELETE;
6035         else if (*s == 's')
6036             squash = OPpTRANS_SQUASH;
6037         else {
6038             switch (count++) {
6039             case 0:
6040                 if (*s == 'C')
6041                     utf8 &= ~OPpTRANS_FROM_UTF;
6042                 else
6043                     utf8 |= OPpTRANS_FROM_UTF;
6044                 break;
6045             case 1:
6046                 if (*s == 'C')
6047                     utf8 &= ~OPpTRANS_TO_UTF;
6048                 else
6049                     utf8 |= OPpTRANS_TO_UTF;
6050                 break;
6051             default:
6052                 Perl_croak(aTHX_ "Too many /C and /U options");
6053             }
6054         }
6055         s++;
6056     }
6057     o->op_private = del|squash|complement|utf8;
6058
6059     PL_lex_op = o;
6060     yylval.ival = OP_TRANS;
6061     return s;
6062 }
6063
6064 STATIC char *
6065 S_scan_heredoc(pTHX_ register char *s)
6066 {
6067     dTHR;
6068     SV *herewas;
6069     I32 op_type = OP_SCALAR;
6070     I32 len;
6071     SV *tmpstr;
6072     char term;
6073     register char *d;
6074     register char *e;
6075     char *peek;
6076     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6077
6078     s += 2;
6079     d = PL_tokenbuf;
6080     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6081     if (!outer)
6082         *d++ = '\n';
6083     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
6084     if (*peek && strchr("`'\"",*peek)) {
6085         s = peek;
6086         term = *s++;
6087         s = delimcpy(d, e, s, PL_bufend, term, &len);
6088         d += len;
6089         if (s < PL_bufend)
6090             s++;
6091     }
6092     else {
6093         if (*s == '\\')
6094             s++, term = '\'';
6095         else
6096             term = '"';
6097         if (!isALNUM_lazy_if(s,UTF))
6098             deprecate("bare << to mean <<\"\"");
6099         for (; isALNUM_lazy_if(s,UTF); s++) {
6100             if (d < e)
6101                 *d++ = *s;
6102         }
6103     }
6104     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6105         Perl_croak(aTHX_ "Delimiter for here document is too long");
6106     *d++ = '\n';
6107     *d = '\0';
6108     len = d - PL_tokenbuf;
6109 #ifndef PERL_STRICT_CR
6110     d = strchr(s, '\r');
6111     if (d) {
6112         char *olds = s;
6113         s = d;
6114         while (s < PL_bufend) {
6115             if (*s == '\r') {
6116                 *d++ = '\n';
6117                 if (*++s == '\n')
6118                     s++;
6119             }
6120             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6121                 *d++ = *s++;
6122                 s++;
6123             }
6124             else
6125                 *d++ = *s++;
6126         }
6127         *d = '\0';
6128         PL_bufend = d;
6129         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6130         s = olds;
6131     }
6132 #endif
6133     d = "\n";
6134     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6135         herewas = newSVpvn(s,PL_bufend-s);
6136     else
6137         s--, herewas = newSVpvn(s,d-s);
6138     s += SvCUR(herewas);
6139
6140     tmpstr = NEWSV(87,79);
6141     sv_upgrade(tmpstr, SVt_PVIV);
6142     if (term == '\'') {
6143         op_type = OP_CONST;
6144         SvIVX(tmpstr) = -1;
6145     }
6146     else if (term == '`') {
6147         op_type = OP_BACKTICK;
6148         SvIVX(tmpstr) = '\\';
6149     }
6150
6151     CLINE;
6152     PL_multi_start = CopLINE(PL_curcop);
6153     PL_multi_open = PL_multi_close = '<';
6154     term = *PL_tokenbuf;
6155     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6156         char *bufptr = PL_sublex_info.super_bufptr;
6157         char *bufend = PL_sublex_info.super_bufend;
6158         char *olds = s - SvCUR(herewas);
6159         s = strchr(bufptr, '\n');
6160         if (!s)
6161             s = bufend;
6162         d = s;
6163         while (s < bufend &&
6164           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6165             if (*s++ == '\n')
6166                 CopLINE_inc(PL_curcop);
6167         }
6168         if (s >= bufend) {
6169             CopLINE_set(PL_curcop, PL_multi_start);
6170             missingterm(PL_tokenbuf);
6171         }
6172         sv_setpvn(herewas,bufptr,d-bufptr+1);
6173         sv_setpvn(tmpstr,d+1,s-d);
6174         s += len - 1;
6175         sv_catpvn(herewas,s,bufend-s);
6176         (void)strcpy(bufptr,SvPVX(herewas));
6177
6178         s = olds;
6179         goto retval;
6180     }
6181     else if (!outer) {
6182         d = s;
6183         while (s < PL_bufend &&
6184           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6185             if (*s++ == '\n')
6186                 CopLINE_inc(PL_curcop);
6187         }
6188         if (s >= PL_bufend) {
6189             CopLINE_set(PL_curcop, PL_multi_start);
6190             missingterm(PL_tokenbuf);
6191         }
6192         sv_setpvn(tmpstr,d+1,s-d);
6193         s += len - 1;
6194         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6195
6196         sv_catpvn(herewas,s,PL_bufend-s);
6197         sv_setsv(PL_linestr,herewas);
6198         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6199         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6200     }
6201     else
6202         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6203     while (s >= PL_bufend) {    /* multiple line string? */
6204         if (!outer ||
6205          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6206             CopLINE_set(PL_curcop, PL_multi_start);
6207             missingterm(PL_tokenbuf);
6208         }
6209         CopLINE_inc(PL_curcop);
6210         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6211 #ifndef PERL_STRICT_CR
6212         if (PL_bufend - PL_linestart >= 2) {
6213             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6214                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6215             {
6216                 PL_bufend[-2] = '\n';
6217                 PL_bufend--;
6218                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6219             }
6220             else if (PL_bufend[-1] == '\r')
6221                 PL_bufend[-1] = '\n';
6222         }
6223         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6224             PL_bufend[-1] = '\n';
6225 #endif
6226         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6227             SV *sv = NEWSV(88,0);
6228
6229             sv_upgrade(sv, SVt_PVMG);
6230             sv_setsv(sv,PL_linestr);
6231             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6232         }
6233         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6234             s = PL_bufend - 1;
6235             *s = ' ';
6236             sv_catsv(PL_linestr,herewas);
6237             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6238         }
6239         else {
6240             s = PL_bufend;
6241             sv_catsv(tmpstr,PL_linestr);
6242         }
6243     }
6244     s++;
6245 retval:
6246     PL_multi_end = CopLINE(PL_curcop);
6247     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6248         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6249         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6250     }
6251     SvREFCNT_dec(herewas);
6252     PL_lex_stuff = tmpstr;
6253     yylval.ival = op_type;
6254     return s;
6255 }
6256
6257 /* scan_inputsymbol
6258    takes: current position in input buffer
6259    returns: new position in input buffer
6260    side-effects: yylval and lex_op are set.
6261
6262    This code handles:
6263
6264    <>           read from ARGV
6265    <FH>         read from filehandle
6266    <pkg::FH>    read from package qualified filehandle
6267    <pkg'FH>     read from package qualified filehandle
6268    <$fh>        read from filehandle in $fh
6269    <*.h>        filename glob
6270
6271 */
6272
6273 STATIC char *
6274 S_scan_inputsymbol(pTHX_ char *start)
6275 {
6276     register char *s = start;           /* current position in buffer */
6277     register char *d;
6278     register char *e;
6279     char *end;
6280     I32 len;
6281
6282     d = PL_tokenbuf;                    /* start of temp holding space */
6283     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6284     end = strchr(s, '\n');
6285     if (!end)
6286         end = PL_bufend;
6287     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6288
6289     /* die if we didn't have space for the contents of the <>,
6290        or if it didn't end, or if we see a newline
6291     */
6292
6293     if (len >= sizeof PL_tokenbuf)
6294         Perl_croak(aTHX_ "Excessively long <> operator");
6295     if (s >= end)
6296         Perl_croak(aTHX_ "Unterminated <> operator");
6297
6298     s++;
6299
6300     /* check for <$fh>
6301        Remember, only scalar variables are interpreted as filehandles by
6302        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6303        treated as a glob() call.
6304        This code makes use of the fact that except for the $ at the front,
6305        a scalar variable and a filehandle look the same.
6306     */
6307     if (*d == '$' && d[1]) d++;
6308
6309     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6310     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6311         d++;
6312
6313     /* If we've tried to read what we allow filehandles to look like, and
6314        there's still text left, then it must be a glob() and not a getline.
6315        Use scan_str to pull out the stuff between the <> and treat it
6316        as nothing more than a string.
6317     */
6318
6319     if (d - PL_tokenbuf != len) {
6320         yylval.ival = OP_GLOB;
6321         set_csh();
6322         s = scan_str(start,FALSE,FALSE);
6323         if (!s)
6324            Perl_croak(aTHX_ "Glob not terminated");
6325         return s;
6326     }
6327     else {
6328         /* we're in a filehandle read situation */
6329         d = PL_tokenbuf;
6330
6331         /* turn <> into <ARGV> */
6332         if (!len)
6333             (void)strcpy(d,"ARGV");
6334
6335         /* if <$fh>, create the ops to turn the variable into a
6336            filehandle
6337         */
6338         if (*d == '$') {
6339             I32 tmp;
6340
6341             /* try to find it in the pad for this block, otherwise find
6342                add symbol table ops
6343             */
6344             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6345                 OP *o = newOP(OP_PADSV, 0);
6346                 o->op_targ = tmp;
6347                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6348             }
6349             else {
6350                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6351                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6352                                             newUNOP(OP_RV2SV, 0,
6353                                                 newGVOP(OP_GV, 0, gv)));
6354             }
6355             PL_lex_op->op_flags |= OPf_SPECIAL;
6356             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6357             yylval.ival = OP_NULL;
6358         }
6359
6360         /* If it's none of the above, it must be a literal filehandle
6361            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6362         else {
6363             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6364             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6365             yylval.ival = OP_NULL;
6366         }
6367     }
6368
6369     return s;
6370 }
6371
6372
6373 /* scan_str
6374    takes: start position in buffer
6375           keep_quoted preserve \ on the embedded delimiter(s)
6376           keep_delims preserve the delimiters around the string
6377    returns: position to continue reading from buffer
6378    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6379         updates the read buffer.
6380
6381    This subroutine pulls a string out of the input.  It is called for:
6382         q               single quotes           q(literal text)
6383         '               single quotes           'literal text'
6384         qq              double quotes           qq(interpolate $here please)
6385         "               double quotes           "interpolate $here please"
6386         qx              backticks               qx(/bin/ls -l)
6387         `               backticks               `/bin/ls -l`
6388         qw              quote words             @EXPORT_OK = qw( func() $spam )
6389         m//             regexp match            m/this/
6390         s///            regexp substitute       s/this/that/
6391         tr///           string transliterate    tr/this/that/
6392         y///            string transliterate    y/this/that/
6393         ($*@)           sub prototypes          sub foo ($)
6394         (stuff)         sub attr parameters     sub foo : attr(stuff)
6395         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6396
6397    In most of these cases (all but <>, patterns and transliterate)
6398    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6399    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6400    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6401    calls scan_str().
6402
6403    It skips whitespace before the string starts, and treats the first
6404    character as the delimiter.  If the delimiter is one of ([{< then
6405    the corresponding "close" character )]}> is used as the closing
6406    delimiter.  It allows quoting of delimiters, and if the string has
6407    balanced delimiters ([{<>}]) it allows nesting.
6408
6409    The lexer always reads these strings into lex_stuff, except in the
6410    case of the operators which take *two* arguments (s/// and tr///)
6411    when it checks to see if lex_stuff is full (presumably with the 1st
6412    arg to s or tr) and if so puts the string into lex_repl.
6413
6414 */
6415
6416 STATIC char *
6417 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6418 {
6419     dTHR;
6420     SV *sv;                             /* scalar value: string */
6421     char *tmps;                         /* temp string, used for delimiter matching */
6422     register char *s = start;           /* current position in the buffer */
6423     register char term;                 /* terminating character */
6424     register char *to;                  /* current position in the sv's data */
6425     I32 brackets = 1;                   /* bracket nesting level */
6426     bool has_utf = FALSE;               /* is there any utf8 content? */
6427
6428     /* skip space before the delimiter */
6429     if (isSPACE(*s))
6430         s = skipspace(s);
6431
6432     /* mark where we are, in case we need to report errors */
6433     CLINE;
6434
6435     /* after skipping whitespace, the next character is the terminator */
6436     term = *s;
6437     if ((term & 0x80) && UTF)
6438         has_utf = TRUE;
6439
6440     /* mark where we are */
6441     PL_multi_start = CopLINE(PL_curcop);
6442     PL_multi_open = term;
6443
6444     /* find corresponding closing delimiter */
6445     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6446         term = tmps[5];
6447     PL_multi_close = term;
6448
6449     /* create a new SV to hold the contents.  87 is leak category, I'm
6450        assuming.  79 is the SV's initial length.  What a random number. */
6451     sv = NEWSV(87,79);
6452     sv_upgrade(sv, SVt_PVIV);
6453     SvIVX(sv) = term;
6454     (void)SvPOK_only(sv);               /* validate pointer */
6455
6456     /* move past delimiter and try to read a complete string */
6457     if (keep_delims)
6458         sv_catpvn(sv, s, 1);
6459     s++;
6460     for (;;) {
6461         /* extend sv if need be */
6462         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6463         /* set 'to' to the next character in the sv's string */
6464         to = SvPVX(sv)+SvCUR(sv);
6465
6466         /* if open delimiter is the close delimiter read unbridle */
6467         if (PL_multi_open == PL_multi_close) {
6468             for (; s < PL_bufend; s++,to++) {
6469                 /* embedded newlines increment the current line number */
6470                 if (*s == '\n' && !PL_rsfp)
6471                     CopLINE_inc(PL_curcop);
6472                 /* handle quoted delimiters */
6473                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6474                     if (!keep_quoted && s[1] == term)
6475                         s++;
6476                 /* any other quotes are simply copied straight through */
6477                     else
6478                         *to++ = *s++;
6479                 }
6480                 /* terminate when run out of buffer (the for() condition), or
6481                    have found the terminator */
6482                 else if (*s == term)
6483                     break;
6484                 else if (!has_utf && (*s & 0x80) && UTF)
6485                     has_utf = TRUE;
6486                 *to = *s;
6487             }
6488         }
6489
6490         /* if the terminator isn't the same as the start character (e.g.,
6491            matched brackets), we have to allow more in the quoting, and
6492            be prepared for nested brackets.
6493         */
6494         else {
6495             /* read until we run out of string, or we find the terminator */
6496             for (; s < PL_bufend; s++,to++) {
6497                 /* embedded newlines increment the line count */
6498                 if (*s == '\n' && !PL_rsfp)
6499                     CopLINE_inc(PL_curcop);
6500                 /* backslashes can escape the open or closing characters */
6501                 if (*s == '\\' && s+1 < PL_bufend) {
6502                     if (!keep_quoted &&
6503                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6504                         s++;
6505                     else
6506                         *to++ = *s++;
6507                 }
6508                 /* allow nested opens and closes */
6509                 else if (*s == PL_multi_close && --brackets <= 0)
6510                     break;
6511                 else if (*s == PL_multi_open)
6512                     brackets++;
6513                 else if (!has_utf && (*s & 0x80) && UTF)
6514                     has_utf = TRUE;
6515                 *to = *s;
6516             }
6517         }
6518         /* terminate the copied string and update the sv's end-of-string */
6519         *to = '\0';
6520         SvCUR_set(sv, to - SvPVX(sv));
6521
6522         /*
6523          * this next chunk reads more into the buffer if we're not done yet
6524          */
6525
6526         if (s < PL_bufend)
6527             break;              /* handle case where we are done yet :-) */
6528
6529 #ifndef PERL_STRICT_CR
6530         if (to - SvPVX(sv) >= 2) {
6531             if ((to[-2] == '\r' && to[-1] == '\n') ||
6532                 (to[-2] == '\n' && to[-1] == '\r'))
6533             {
6534                 to[-2] = '\n';
6535                 to--;
6536                 SvCUR_set(sv, to - SvPVX(sv));
6537             }
6538             else if (to[-1] == '\r')
6539                 to[-1] = '\n';
6540         }
6541         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6542             to[-1] = '\n';
6543 #endif
6544
6545         /* if we're out of file, or a read fails, bail and reset the current
6546            line marker so we can report where the unterminated string began
6547         */
6548         if (!PL_rsfp ||
6549          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6550             sv_free(sv);
6551             CopLINE_set(PL_curcop, PL_multi_start);
6552             return Nullch;
6553         }
6554         /* we read a line, so increment our line counter */
6555         CopLINE_inc(PL_curcop);
6556
6557         /* update debugger info */
6558         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6559             SV *sv = NEWSV(88,0);
6560
6561             sv_upgrade(sv, SVt_PVMG);
6562             sv_setsv(sv,PL_linestr);
6563             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6564         }
6565
6566         /* having changed the buffer, we must update PL_bufend */
6567         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6568     }
6569
6570     /* at this point, we have successfully read the delimited string */
6571
6572     if (keep_delims)
6573         sv_catpvn(sv, s, 1);
6574     if (has_utf)
6575         SvUTF8_on(sv);
6576     PL_multi_end = CopLINE(PL_curcop);
6577     s++;
6578
6579     /* if we allocated too much space, give some back */
6580     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6581         SvLEN_set(sv, SvCUR(sv) + 1);
6582         Renew(SvPVX(sv), SvLEN(sv), char);
6583     }
6584
6585     /* decide whether this is the first or second quoted string we've read
6586        for this op
6587     */
6588
6589     if (PL_lex_stuff)
6590         PL_lex_repl = sv;
6591     else
6592         PL_lex_stuff = sv;
6593     return s;
6594 }
6595
6596 /*
6597   scan_num
6598   takes: pointer to position in buffer
6599   returns: pointer to new position in buffer
6600   side-effects: builds ops for the constant in yylval.op
6601
6602   Read a number in any of the formats that Perl accepts:
6603
6604   0(x[0-7A-F]+)|([0-7]+)|(b[01])
6605   [\d_]+(\.[\d_]*)?[Ee](\d+)
6606
6607   Underbars (_) are allowed in decimal numbers.  If -w is on,
6608   underbars before a decimal point must be at three digit intervals.
6609
6610   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6611   thing it reads.
6612
6613   If it reads a number without a decimal point or an exponent, it will
6614   try converting the number to an integer and see if it can do so
6615   without loss of precision.
6616 */
6617
6618 char *
6619 Perl_scan_num(pTHX_ char *start)
6620 {
6621     register char *s = start;           /* current position in buffer */
6622     register char *d;                   /* destination in temp buffer */
6623     register char *e;                   /* end of temp buffer */
6624     IV tryiv;                           /* used to see if it can be an IV */
6625     NV value;                           /* number read, as a double */
6626     SV *sv = Nullsv;                    /* place to put the converted number */
6627     bool floatit;                       /* boolean: int or float? */
6628     char *lastub = 0;                   /* position of last underbar */
6629     static char number_too_long[] = "Number too long";
6630
6631     /* We use the first character to decide what type of number this is */
6632
6633     switch (*s) {
6634     default:
6635       Perl_croak(aTHX_ "panic: scan_num");
6636
6637     /* if it starts with a 0, it could be an octal number, a decimal in
6638        0.13 disguise, or a hexadecimal number, or a binary number. */
6639     case '0':
6640         {
6641           /* variables:
6642              u          holds the "number so far"
6643              shift      the power of 2 of the base
6644                         (hex == 4, octal == 3, binary == 1)
6645              overflowed was the number more than we can hold?
6646
6647              Shift is used when we add a digit.  It also serves as an "are
6648              we in octal/hex/binary?" indicator to disallow hex characters
6649              when in octal mode.
6650            */
6651             dTHR;
6652             NV n = 0.0;
6653             UV u = 0;
6654             I32 shift;
6655             bool overflowed = FALSE;
6656             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6657             static char* bases[5] = { "", "binary", "", "octal",
6658                                       "hexadecimal" };
6659             static char* Bases[5] = { "", "Binary", "", "Octal",
6660                                       "Hexadecimal" };
6661             static char *maxima[5] = { "",
6662                                        "0b11111111111111111111111111111111",
6663                                        "",
6664                                        "037777777777",
6665                                        "0xffffffff" };
6666             char *base, *Base, *max;
6667
6668             /* check for hex */
6669             if (s[1] == 'x') {
6670                 shift = 4;
6671                 s += 2;
6672             } else if (s[1] == 'b') {
6673                 shift = 1;
6674                 s += 2;
6675             }
6676             /* check for a decimal in disguise */
6677             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6678                 goto decimal;
6679             /* so it must be octal */
6680             else
6681                 shift = 3;
6682
6683             base = bases[shift];
6684             Base = Bases[shift];
6685             max  = maxima[shift];
6686
6687             /* read the rest of the number */
6688             for (;;) {
6689                 /* x is used in the overflow test,
6690                    b is the digit we're adding on. */
6691                 UV x, b;
6692
6693                 switch (*s) {
6694
6695                 /* if we don't mention it, we're done */
6696                 default:
6697                     goto out;
6698
6699                 /* _ are ignored */
6700                 case '_':
6701                     s++;
6702                     break;
6703
6704                 /* 8 and 9 are not octal */
6705                 case '8': case '9':
6706                     if (shift == 3)
6707                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6708                     /* FALL THROUGH */
6709
6710                 /* octal digits */
6711                 case '2': case '3': case '4':
6712                 case '5': case '6': case '7':
6713                     if (shift == 1)
6714                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6715                     /* FALL THROUGH */
6716
6717                 case '0': case '1':
6718                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6719                     goto digit;
6720
6721                 /* hex digits */
6722                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6723                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6724                     /* make sure they said 0x */
6725                     if (shift != 4)
6726                         goto out;
6727                     b = (*s++ & 7) + 9;
6728
6729                     /* Prepare to put the digit we have onto the end
6730                        of the number so far.  We check for overflows.
6731                     */
6732
6733                   digit:
6734                     if (!overflowed) {
6735                         x = u << shift; /* make room for the digit */
6736
6737                         if ((x >> shift) != u
6738                             && !(PL_hints & HINT_NEW_BINARY)) {
6739                             dTHR;
6740                             overflowed = TRUE;
6741                             n = (NV) u;
6742                             if (ckWARN_d(WARN_OVERFLOW))
6743                                 Perl_warner(aTHX_ WARN_OVERFLOW,
6744                                             "Integer overflow in %s number",
6745                                             base);
6746                         } else
6747                             u = x | b;          /* add the digit to the end */
6748                     }
6749                     if (overflowed) {
6750                         n *= nvshift[shift];
6751                         /* If an NV has not enough bits in its
6752                          * mantissa to represent an UV this summing of
6753                          * small low-order numbers is a waste of time
6754                          * (because the NV cannot preserve the
6755                          * low-order bits anyway): we could just
6756                          * remember when did we overflow and in the
6757                          * end just multiply n by the right
6758                          * amount. */
6759                         n += (NV) b;
6760                     }
6761                     break;
6762                 }
6763             }
6764
6765           /* if we get here, we had success: make a scalar value from
6766              the number.
6767           */
6768           out:
6769             sv = NEWSV(92,0);
6770             if (overflowed) {
6771                 dTHR;
6772                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
6773                     Perl_warner(aTHX_ WARN_PORTABLE,
6774                                 "%s number > %s non-portable",
6775                                 Base, max);
6776                 sv_setnv(sv, n);
6777             }
6778             else {
6779 #if UVSIZE > 4
6780                 dTHR;
6781                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
6782                     Perl_warner(aTHX_ WARN_PORTABLE,
6783                                 "%s number > %s non-portable",
6784                                 Base, max);
6785 #endif
6786                 sv_setuv(sv, u);
6787             }
6788             if (PL_hints & HINT_NEW_BINARY)
6789                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6790         }
6791         break;
6792
6793     /*
6794       handle decimal numbers.
6795       we're also sent here when we read a 0 as the first digit
6796     */
6797     case '1': case '2': case '3': case '4': case '5':
6798     case '6': case '7': case '8': case '9': case '.':
6799       decimal:
6800         d = PL_tokenbuf;
6801         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6802         floatit = FALSE;
6803
6804         /* read next group of digits and _ and copy into d */
6805         while (isDIGIT(*s) || *s == '_') {
6806             /* skip underscores, checking for misplaced ones
6807                if -w is on
6808             */
6809             if (*s == '_') {
6810                 dTHR;                   /* only for ckWARN */
6811                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6812                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6813                 lastub = ++s;
6814             }
6815             else {
6816                 /* check for end of fixed-length buffer */
6817                 if (d >= e)
6818                     Perl_croak(aTHX_ number_too_long);
6819                 /* if we're ok, copy the character */
6820                 *d++ = *s++;
6821             }
6822         }
6823
6824         /* final misplaced underbar check */
6825         if (lastub && s - lastub != 3) {
6826             dTHR;
6827             if (ckWARN(WARN_SYNTAX))
6828                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6829         }
6830
6831         /* read a decimal portion if there is one.  avoid
6832            3..5 being interpreted as the number 3. followed
6833            by .5
6834         */
6835         if (*s == '.' && s[1] != '.') {
6836             floatit = TRUE;
6837             *d++ = *s++;
6838
6839             /* copy, ignoring underbars, until we run out of
6840                digits.  Note: no misplaced underbar checks!
6841             */
6842             for (; isDIGIT(*s) || *s == '_'; s++) {
6843                 /* fixed length buffer check */
6844                 if (d >= e)
6845                     Perl_croak(aTHX_ number_too_long);
6846                 if (*s != '_')
6847                     *d++ = *s;
6848             }
6849         }
6850
6851         /* read exponent part, if present */
6852         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6853             floatit = TRUE;
6854             s++;
6855
6856             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6857             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6858
6859             /* allow positive or negative exponent */
6860             if (*s == '+' || *s == '-')
6861                 *d++ = *s++;
6862
6863             /* read digits of exponent (no underbars :-) */
6864             while (isDIGIT(*s)) {
6865                 if (d >= e)
6866                     Perl_croak(aTHX_ number_too_long);
6867                 *d++ = *s++;
6868             }
6869         }
6870
6871         /* terminate the string */
6872         *d = '\0';
6873
6874         /* make an sv from the string */
6875         sv = NEWSV(92,0);
6876
6877         value = Atof(PL_tokenbuf);
6878
6879         /*
6880            See if we can make do with an integer value without loss of
6881            precision.  We use I_V to cast to an int, because some
6882            compilers have issues.  Then we try casting it back and see
6883            if it was the same.  We only do this if we know we
6884            specifically read an integer.
6885
6886            Note: if floatit is true, then we don't need to do the
6887            conversion at all.
6888         */
6889         tryiv = I_V(value);
6890         if (!floatit && (NV)tryiv == value)
6891             sv_setiv(sv, tryiv);
6892         else
6893             sv_setnv(sv, value);
6894         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
6895                        (PL_hints & HINT_NEW_INTEGER) )
6896             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6897                               (floatit ? "float" : "integer"),
6898                               sv, Nullsv, NULL);
6899         break;
6900     /* if it starts with a v, it could be a version number */
6901     case 'v':
6902         {
6903             char *pos = s;
6904             pos++;
6905             while (isDIGIT(*pos))
6906                 pos++;
6907             if (*pos == '.' && isDIGIT(pos[1])) {
6908                 UV rev;
6909                 U8 tmpbuf[UTF8_MAXLEN];
6910                 U8 *tmpend;
6911                 bool utf8 = FALSE;
6912                 s++;                            /* get past 'v' */
6913
6914                 sv = NEWSV(92,5);
6915                 sv_setpvn(sv, "", 0);
6916
6917                 do {
6918                     if (*s == '0' && isDIGIT(s[1]))
6919                         yyerror("Octal number in vector unsupported");
6920                     rev = atoi(s);
6921                     s = ++pos;
6922                     while (isDIGIT(*pos))
6923                         pos++;
6924
6925                     if (rev > 127) {
6926                         tmpend = uv_to_utf8(tmpbuf, rev);
6927                         utf8 = TRUE;
6928                     }
6929                     else {
6930                         tmpbuf[0] = (U8)rev;
6931                         tmpend = &tmpbuf[1];
6932                     }
6933                     sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6934                 } while (*pos == '.' && isDIGIT(pos[1]));
6935
6936                 if (*s == '0' && isDIGIT(s[1]))
6937                     yyerror("Octal number in vector unsupported");
6938                 rev = atoi(s);
6939                 s = pos;
6940                 tmpend = uv_to_utf8(tmpbuf, rev);
6941                 utf8 = utf8 || rev > 127;
6942                 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
6943
6944                 SvPOK_on(sv);
6945                 SvREADONLY_on(sv);
6946                 if (utf8) {
6947                     SvUTF8_on(sv);
6948                     sv_utf8_downgrade(sv, TRUE);
6949                 }
6950             }
6951         }
6952         break;
6953     }
6954
6955     /* make the op for the constant and return */
6956
6957     if (sv)
6958         yylval.opval = newSVOP(OP_CONST, 0, sv);
6959     else
6960         yylval.opval = Nullop;
6961
6962     return s;
6963 }
6964
6965 STATIC char *
6966 S_scan_formline(pTHX_ register char *s)
6967 {
6968     dTHR;
6969     register char *eol;
6970     register char *t;
6971     SV *stuff = newSVpvn("",0);
6972     bool needargs = FALSE;
6973
6974     while (!needargs) {
6975         if (*s == '.' || *s == '}') {
6976             /*SUPPRESS 530*/
6977 #ifdef PERL_STRICT_CR
6978             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6979 #else
6980             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6981 #endif
6982             if (*t == '\n' || t == PL_bufend)
6983                 break;
6984         }
6985         if (PL_in_eval && !PL_rsfp) {
6986             eol = strchr(s,'\n');
6987             if (!eol++)
6988                 eol = PL_bufend;
6989         }
6990         else
6991             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6992         if (*s != '#') {
6993             for (t = s; t < eol; t++) {
6994                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6995                     needargs = FALSE;
6996                     goto enough;        /* ~~ must be first line in formline */
6997                 }
6998                 if (*t == '@' || *t == '^')
6999                     needargs = TRUE;
7000             }
7001             sv_catpvn(stuff, s, eol-s);
7002 #ifndef PERL_STRICT_CR
7003             if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7004                 char *end = SvPVX(stuff) + SvCUR(stuff);
7005                 end[-2] = '\n';
7006                 end[-1] = '\0';
7007                 SvCUR(stuff)--;
7008             }
7009 #endif
7010         }
7011         s = eol;
7012         if (PL_rsfp) {
7013             s = filter_gets(PL_linestr, PL_rsfp, 0);
7014             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7015             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7016             if (!s) {
7017                 s = PL_bufptr;
7018                 yyerror("Format not terminated");
7019                 break;
7020             }
7021         }
7022         incline(s);
7023     }
7024   enough:
7025     if (SvCUR(stuff)) {
7026         PL_expect = XTERM;
7027         if (needargs) {
7028             PL_lex_state = LEX_NORMAL;
7029             PL_nextval[PL_nexttoke].ival = 0;
7030             force_next(',');
7031         }
7032         else
7033             PL_lex_state = LEX_FORMLINE;
7034         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7035         force_next(THING);
7036         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7037         force_next(LSTOP);
7038     }
7039     else {
7040         SvREFCNT_dec(stuff);
7041         PL_lex_formbrack = 0;
7042         PL_bufptr = s;
7043     }
7044     return s;
7045 }
7046
7047 STATIC void
7048 S_set_csh(pTHX)
7049 {
7050 #ifdef CSH
7051     if (!PL_cshlen)
7052         PL_cshlen = strlen(PL_cshname);
7053 #endif
7054 }
7055
7056 I32
7057 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7058 {
7059     dTHR;
7060     I32 oldsavestack_ix = PL_savestack_ix;
7061     CV* outsidecv = PL_compcv;
7062     AV* comppadlist;
7063
7064     if (PL_compcv) {
7065         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7066     }
7067     SAVEI32(PL_subline);
7068     save_item(PL_subname);
7069     SAVEI32(PL_padix);
7070     SAVECOMPPAD();
7071     SAVESPTR(PL_comppad_name);
7072     SAVESPTR(PL_compcv);
7073     SAVEI32(PL_comppad_name_fill);
7074     SAVEI32(PL_min_intro_pending);
7075     SAVEI32(PL_max_intro_pending);
7076     SAVEI32(PL_pad_reset_pending);
7077
7078     PL_compcv = (CV*)NEWSV(1104,0);
7079     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7080     CvFLAGS(PL_compcv) |= flags;
7081
7082     PL_comppad = newAV();
7083     av_push(PL_comppad, Nullsv);
7084     PL_curpad = AvARRAY(PL_comppad);
7085     PL_comppad_name = newAV();
7086     PL_comppad_name_fill = 0;
7087     PL_min_intro_pending = 0;
7088     PL_padix = 0;
7089     PL_subline = CopLINE(PL_curcop);
7090 #ifdef USE_THREADS
7091     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7092     PL_curpad[0] = (SV*)newAV();
7093     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7094 #endif /* USE_THREADS */
7095
7096     comppadlist = newAV();
7097     AvREAL_off(comppadlist);
7098     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7099     av_store(comppadlist, 1, (SV*)PL_comppad);
7100
7101     CvPADLIST(PL_compcv) = comppadlist;
7102     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7103 #ifdef USE_THREADS
7104     CvOWNER(PL_compcv) = 0;
7105     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7106     MUTEX_INIT(CvMUTEXP(PL_compcv));
7107 #endif /* USE_THREADS */
7108
7109     return oldsavestack_ix;
7110 }
7111
7112 int
7113 Perl_yywarn(pTHX_ char *s)
7114 {
7115     dTHR;
7116     PL_in_eval |= EVAL_WARNONLY;
7117     yyerror(s);
7118     PL_in_eval &= ~EVAL_WARNONLY;
7119     return 0;
7120 }
7121
7122 int
7123 Perl_yyerror(pTHX_ char *s)
7124 {
7125     dTHR;
7126     char *where = NULL;
7127     char *context = NULL;
7128     int contlen = -1;
7129     SV *msg;
7130
7131     if (!yychar || (yychar == ';' && !PL_rsfp))
7132         where = "at EOF";
7133     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7134       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7135         while (isSPACE(*PL_oldoldbufptr))
7136             PL_oldoldbufptr++;
7137         context = PL_oldoldbufptr;
7138         contlen = PL_bufptr - PL_oldoldbufptr;
7139     }
7140     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7141       PL_oldbufptr != PL_bufptr) {
7142         while (isSPACE(*PL_oldbufptr))
7143             PL_oldbufptr++;
7144         context = PL_oldbufptr;
7145         contlen = PL_bufptr - PL_oldbufptr;
7146     }
7147     else if (yychar > 255)
7148         where = "next token ???";
7149 #ifdef USE_PURE_BISON
7150 /*  GNU Bison sets the value -2 */
7151     else if (yychar == -2) {
7152 #else
7153     else if ((yychar & 127) == 127) {
7154 #endif
7155         if (PL_lex_state == LEX_NORMAL ||
7156            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7157             where = "at end of line";
7158         else if (PL_lex_inpat)
7159             where = "within pattern";
7160         else
7161             where = "within string";
7162     }
7163     else {
7164         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7165         if (yychar < 32)
7166             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7167         else if (isPRINT_LC(yychar))
7168             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7169         else
7170             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7171         where = SvPVX(where_sv);
7172     }
7173     msg = sv_2mortal(newSVpv(s, 0));
7174     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7175                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7176     if (context)
7177         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7178     else
7179         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7180     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7181         Perl_sv_catpvf(aTHX_ msg,
7182         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7183                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7184         PL_multi_end = 0;
7185     }
7186     if (PL_in_eval & EVAL_WARNONLY)
7187         Perl_warn(aTHX_ "%"SVf, msg);
7188     else
7189         qerror(msg);
7190     if (PL_error_count >= 10)
7191         Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
7192     PL_in_my = 0;
7193     PL_in_my_stash = Nullhv;
7194     return 0;
7195 }
7196
7197
7198 #ifdef PERL_OBJECT
7199 #include "XSUB.h"
7200 #endif
7201
7202 /*
7203  * restore_rsfp
7204  * Restore a source filter.
7205  */
7206
7207 static void
7208 restore_rsfp(pTHXo_ void *f)
7209 {
7210     PerlIO *fp = (PerlIO*)f;
7211
7212     if (PL_rsfp == PerlIO_stdin())
7213         PerlIO_clearerr(PL_rsfp);
7214     else if (PL_rsfp && (PL_rsfp != fp))
7215         PerlIO_close(PL_rsfp);
7216     PL_rsfp = fp;
7217 }