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