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