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