toke.c

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