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                 if (*s == ':' && s[1] != ':')
2801                     s = skipspace(s+1);
2802                 else if (s == d)
2803                     break;      /* require real whitespace or :'s */
2804             }
2805             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2806             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2807                 char q = ((*s == '\'') ? '"' : '\'');
2808                 /* If here for an expression, and parsed no attrs, back off. */
2809                 if (tmp == '=' && !attrs) {
2810                     s = PL_bufptr;
2811                     break;
2812                 }
2813                 /* MUST advance bufptr here to avoid bogus "at end of line"
2814                    context messages from yyerror().
2815                  */
2816                 PL_bufptr = s;
2817                 if (!*s)
2818                     yyerror("Unterminated attribute list");
2819                 else
2820                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2821                                       q, *s, q));
2822                 if (attrs)
2823                     op_free(attrs);
2824                 OPERATOR(':');
2825             }
2826         got_attrs:
2827             if (attrs) {
2828                 PL_nextval[PL_nexttoke].opval = attrs;
2829                 force_next(THING);
2830             }
2831             TOKEN(COLONATTR);
2832         }
2833         OPERATOR(':');
2834     case '(':
2835         s++;
2836         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2837             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2838         else
2839             PL_expect = XTERM;
2840         TOKEN('(');
2841     case ';':
2842         if (CopLINE(PL_curcop) < PL_copline)
2843             PL_copline = CopLINE(PL_curcop);
2844         tmp = *s++;
2845         OPERATOR(tmp);
2846     case ')':
2847         tmp = *s++;
2848         s = skipspace(s);
2849         if (*s == '{')
2850             PREBLOCK(tmp);
2851         TERM(tmp);
2852     case ']':
2853         s++;
2854         if (PL_lex_brackets <= 0)
2855             yyerror("Unmatched right square bracket");
2856         else
2857             --PL_lex_brackets;
2858         if (PL_lex_state == LEX_INTERPNORMAL) {
2859             if (PL_lex_brackets == 0) {
2860                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2861                     PL_lex_state = LEX_INTERPEND;
2862             }
2863         }
2864         TERM(']');
2865     case '{':
2866       leftbracket:
2867         s++;
2868         if (PL_lex_brackets > 100) {
2869             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2870             if (newlb != PL_lex_brackstack) {
2871                 SAVEFREEPV(newlb);
2872                 PL_lex_brackstack = newlb;
2873             }
2874         }
2875         switch (PL_expect) {
2876         case XTERM:
2877             if (PL_lex_formbrack) {
2878                 s--;
2879                 PRETERMBLOCK(DO);
2880             }
2881             if (PL_oldoldbufptr == PL_last_lop)
2882                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2883             else
2884                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2885             OPERATOR(HASHBRACK);
2886         case XOPERATOR:
2887             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2888                 s++;
2889             d = s;
2890             PL_tokenbuf[0] = '\0';
2891             if (d < PL_bufend && *d == '-') {
2892                 PL_tokenbuf[0] = '-';
2893                 d++;
2894                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2895                     d++;
2896             }
2897             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2898                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2899                               FALSE, &len);
2900                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2901                     d++;
2902                 if (*d == '}') {
2903                     char minus = (PL_tokenbuf[0] == '-');
2904                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2905                     if (minus)
2906                         force_next('-');
2907                 }
2908             }
2909             /* FALL THROUGH */
2910         case XATTRBLOCK:
2911         case XBLOCK:
2912             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2913             PL_expect = XSTATE;
2914             break;
2915         case XATTRTERM:
2916         case XTERMBLOCK:
2917             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2918             PL_expect = XSTATE;
2919             break;
2920         default: {
2921                 char *t;
2922                 if (PL_oldoldbufptr == PL_last_lop)
2923                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2924                 else
2925                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2926                 s = skipspace(s);
2927                 if (*s == '}')
2928                     OPERATOR(HASHBRACK);
2929                 /* This hack serves to disambiguate a pair of curlies
2930                  * as being a block or an anon hash.  Normally, expectation
2931                  * determines that, but in cases where we're not in a
2932                  * position to expect anything in particular (like inside
2933                  * eval"") we have to resolve the ambiguity.  This code
2934                  * covers the case where the first term in the curlies is a
2935                  * quoted string.  Most other cases need to be explicitly
2936                  * disambiguated by prepending a `+' before the opening
2937                  * curly in order to force resolution as an anon hash.
2938                  *
2939                  * XXX should probably propagate the outer expectation
2940                  * into eval"" to rely less on this hack, but that could
2941                  * potentially break current behavior of eval"".
2942                  * GSAR 97-07-21
2943                  */
2944                 t = s;
2945                 if (*s == '\'' || *s == '"' || *s == '`') {
2946                     /* common case: get past first string, handling escapes */
2947                     for (t++; t < PL_bufend && *t != *s;)
2948                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2949                             t++;
2950                     t++;
2951                 }
2952                 else if (*s == 'q') {
2953                     if (++t < PL_bufend
2954                         && (!isALNUM(*t)
2955                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2956                                 && !isALNUM(*t))))
2957                     {
2958                         char *tmps;
2959                         char open, close, term;
2960                         I32 brackets = 1;
2961
2962                         while (t < PL_bufend && isSPACE(*t))
2963                             t++;
2964                         term = *t;
2965                         open = term;
2966                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2967                             term = tmps[5];
2968                         close = term;
2969                         if (open == close)
2970                             for (t++; t < PL_bufend; t++) {
2971                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2972                                     t++;
2973                                 else if (*t == open)
2974                                     break;
2975                             }
2976                         else
2977                             for (t++; t < PL_bufend; t++) {
2978                                 if (*t == '\\' && t+1 < PL_bufend)
2979                                     t++;
2980                                 else if (*t == close && --brackets <= 0)
2981                                     break;
2982                                 else if (*t == open)
2983                                     brackets++;
2984                             }
2985                     }
2986                     t++;
2987                 }
2988                 else if (isALNUM_lazy(t)) {
2989                     t += UTF8SKIP(t);
2990                     while (t < PL_bufend && isALNUM_lazy(t))
2991                          t += UTF8SKIP(t);
2992                 }
2993                 while (t < PL_bufend && isSPACE(*t))
2994                     t++;
2995                 /* if comma follows first term, call it an anon hash */
2996                 /* XXX it could be a comma expression with loop modifiers */
2997                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2998                                    || (*t == '=' && t[1] == '>')))
2999                     OPERATOR(HASHBRACK);
3000                 if (PL_expect == XREF)
3001                     PL_expect = XTERM;
3002                 else {
3003                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3004                     PL_expect = XSTATE;
3005                 }
3006             }
3007             break;
3008         }
3009         yylval.ival = CopLINE(PL_curcop);
3010         if (isSPACE(*s) || *s == '#')
3011             PL_copline = NOLINE;   /* invalidate current command line number */
3012         TOKEN('{');
3013     case '}':
3014       rightbracket:
3015         s++;
3016         if (PL_lex_brackets <= 0)
3017             yyerror("Unmatched right curly bracket");
3018         else
3019             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3020         if (PL_lex_brackets < PL_lex_formbrack)
3021             PL_lex_formbrack = 0;
3022         if (PL_lex_state == LEX_INTERPNORMAL) {
3023             if (PL_lex_brackets == 0) {
3024                 if (PL_expect & XFAKEBRACK) {
3025                     PL_expect &= XENUMMASK;
3026                     PL_lex_state = LEX_INTERPEND;
3027                     PL_bufptr = s;
3028                     return yylex();     /* ignore fake brackets */
3029                 }
3030                 if (*s == '-' && s[1] == '>')
3031                     PL_lex_state = LEX_INTERPENDMAYBE;
3032                 else if (*s != '[' && *s != '{')
3033                     PL_lex_state = LEX_INTERPEND;
3034             }
3035         }
3036         if (PL_expect & XFAKEBRACK) {
3037             PL_expect &= XENUMMASK;
3038             PL_bufptr = s;
3039             return yylex();             /* ignore fake brackets */
3040         }
3041         force_next('}');
3042         TOKEN(';');
3043     case '&':
3044         s++;
3045         tmp = *s++;
3046         if (tmp == '&')
3047             AOPERATOR(ANDAND);
3048         s--;
3049         if (PL_expect == XOPERATOR) {
3050             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
3051                 CopLINE_dec(PL_curcop);
3052                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3053                 CopLINE_inc(PL_curcop);
3054             }
3055             BAop(OP_BIT_AND);
3056         }
3057
3058         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3059         if (*PL_tokenbuf) {
3060             PL_expect = XOPERATOR;
3061             force_ident(PL_tokenbuf, '&');
3062         }
3063         else
3064             PREREF('&');
3065         yylval.ival = (OPpENTERSUB_AMPER<<8);
3066         TERM('&');
3067
3068     case '|':
3069         s++;
3070         tmp = *s++;
3071         if (tmp == '|')
3072             AOPERATOR(OROR);
3073         s--;
3074         BOop(OP_BIT_OR);
3075     case '=':
3076         s++;
3077         tmp = *s++;
3078         if (tmp == '=')
3079             Eop(OP_EQ);
3080         if (tmp == '>')
3081             OPERATOR(',');
3082         if (tmp == '~')
3083             PMop(OP_MATCH);
3084         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3085             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3086         s--;
3087         if (PL_expect == XSTATE && isALPHA(tmp) &&
3088                 (s == PL_linestart+1 || s[-2] == '\n') )
3089         {
3090             if (PL_in_eval && !PL_rsfp) {
3091                 d = PL_bufend;
3092                 while (s < d) {
3093                     if (*s++ == '\n') {
3094                         incline(s);
3095                         if (strnEQ(s,"=cut",4)) {
3096                             s = strchr(s,'\n');
3097                             if (s)
3098                                 s++;
3099                             else
3100                                 s = d;
3101                             incline(s);
3102                             goto retry;
3103                         }
3104                     }
3105                 }
3106                 goto retry;
3107             }
3108             s = PL_bufend;
3109             PL_doextract = TRUE;
3110             goto retry;
3111         }
3112         if (PL_lex_brackets < PL_lex_formbrack) {
3113             char *t;
3114 #ifdef PERL_STRICT_CR
3115             for (t = s; *t == ' ' || *t == '\t'; t++) ;
3116 #else
3117             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3118 #endif
3119             if (*t == '\n' || *t == '#') {
3120                 s--;
3121                 PL_expect = XBLOCK;
3122                 goto leftbracket;
3123             }
3124         }
3125         yylval.ival = 0;
3126         OPERATOR(ASSIGNOP);
3127     case '!':
3128         s++;
3129         tmp = *s++;
3130         if (tmp == '=')
3131             Eop(OP_NE);
3132         if (tmp == '~')
3133             PMop(OP_NOT);
3134         s--;
3135         OPERATOR('!');
3136     case '<':
3137         if (PL_expect != XOPERATOR) {
3138             if (s[1] != '<' && !strchr(s,'>'))
3139                 check_uni();
3140             if (s[1] == '<')
3141                 s = scan_heredoc(s);
3142             else
3143                 s = scan_inputsymbol(s);
3144             TERM(sublex_start());
3145         }
3146         s++;
3147         tmp = *s++;
3148         if (tmp == '<')
3149             SHop(OP_LEFT_SHIFT);
3150         if (tmp == '=') {
3151             tmp = *s++;
3152             if (tmp == '>')
3153                 Eop(OP_NCMP);
3154             s--;
3155             Rop(OP_LE);
3156         }
3157         s--;
3158         Rop(OP_LT);
3159     case '>':
3160         s++;
3161         tmp = *s++;
3162         if (tmp == '>')
3163             SHop(OP_RIGHT_SHIFT);
3164         if (tmp == '=')
3165             Rop(OP_GE);
3166         s--;
3167         Rop(OP_GT);
3168
3169     case '$':
3170         CLINE;
3171
3172         if (PL_expect == XOPERATOR) {
3173             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3174                 PL_expect = XTERM;
3175                 depcom();
3176                 return ','; /* grandfather non-comma-format format */
3177             }
3178         }
3179
3180         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
3181             PL_tokenbuf[0] = '@';
3182             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3183                            sizeof PL_tokenbuf - 1, FALSE);
3184             if (PL_expect == XOPERATOR)
3185                 no_op("Array length", s);
3186             if (!PL_tokenbuf[1])
3187                 PREREF(DOLSHARP);
3188             PL_expect = XOPERATOR;
3189             PL_pending_ident = '#';
3190             TOKEN(DOLSHARP);
3191         }
3192
3193         PL_tokenbuf[0] = '$';
3194         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3195                        sizeof PL_tokenbuf - 1, FALSE);
3196         if (PL_expect == XOPERATOR)
3197             no_op("Scalar", s);
3198         if (!PL_tokenbuf[1]) {
3199             if (s == PL_bufend)
3200                 yyerror("Final $ should be \\$ or $name");
3201             PREREF('$');
3202         }
3203
3204         /* This kludge not intended to be bulletproof. */
3205         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3206             yylval.opval = newSVOP(OP_CONST, 0,
3207                                    newSViv((IV)PL_compiling.cop_arybase));
3208             yylval.opval->op_private = OPpCONST_ARYBASE;
3209             TERM(THING);
3210         }
3211
3212         d = s;
3213         tmp = (I32)*s;
3214         if (PL_lex_state == LEX_NORMAL)
3215             s = skipspace(s);
3216
3217         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3218             char *t;
3219             if (*s == '[') {
3220                 PL_tokenbuf[0] = '@';
3221                 if (ckWARN(WARN_SYNTAX)) {
3222                     for(t = s + 1;
3223                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
3224                         t++) ;
3225                     if (*t++ == ',') {
3226                         PL_bufptr = skipspace(PL_bufptr);
3227                         while (t < PL_bufend && *t != ']')
3228                             t++;
3229                         Perl_warner(aTHX_ WARN_SYNTAX,
3230                                 "Multidimensional syntax %.*s not supported",
3231                                 (t - PL_bufptr) + 1, PL_bufptr);
3232                     }
3233                 }
3234             }
3235             else if (*s == '{') {
3236                 PL_tokenbuf[0] = '%';
3237                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3238                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3239                 {
3240                     char tmpbuf[sizeof PL_tokenbuf];
3241                     STRLEN len;
3242                     for (t++; isSPACE(*t); t++) ;
3243                     if (isIDFIRST_lazy(t)) {
3244                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3245                         for (; isSPACE(*t); t++) ;
3246                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3247                             Perl_warner(aTHX_ WARN_SYNTAX,
3248                                 "You need to quote \"%s\"", tmpbuf);
3249                     }
3250                 }
3251             }
3252         }
3253
3254         PL_expect = XOPERATOR;
3255         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3256             bool islop = (PL_last_lop == PL_oldoldbufptr);
3257             if (!islop || PL_last_lop_op == OP_GREPSTART)
3258                 PL_expect = XOPERATOR;
3259             else if (strchr("$@\"'`q", *s))
3260                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3261             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
3262                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3263             else if (isIDFIRST_lazy(s)) {
3264                 char tmpbuf[sizeof PL_tokenbuf];
3265                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3266                 if (tmp = keyword(tmpbuf, len)) {
3267                     /* binary operators exclude handle interpretations */
3268                     switch (tmp) {
3269                     case -KEY_x:
3270                     case -KEY_eq:
3271                     case -KEY_ne:
3272                     case -KEY_gt:
3273                     case -KEY_lt:
3274                     case -KEY_ge:
3275                     case -KEY_le:
3276                     case -KEY_cmp:
3277                         break;
3278                     default:
3279                         PL_expect = XTERM;      /* e.g. print $fh length() */
3280                         break;
3281                     }
3282                 }
3283                 else {
3284                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3285                     if (gv && GvCVu(gv))
3286                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3287                 }
3288             }
3289             else if (isDIGIT(*s))
3290                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3291             else if (*s == '.' && isDIGIT(s[1]))
3292                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3293             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3294                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3295             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3296                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3297         }
3298         PL_pending_ident = '$';
3299         TOKEN('$');
3300
3301     case '@':
3302         if (PL_expect == XOPERATOR)
3303             no_op("Array", s);
3304         PL_tokenbuf[0] = '@';
3305         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3306         if (!PL_tokenbuf[1]) {
3307             if (s == PL_bufend)
3308                 yyerror("Final @ should be \\@ or @name");
3309             PREREF('@');
3310         }
3311         if (PL_lex_state == LEX_NORMAL)
3312             s = skipspace(s);
3313         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3314             if (*s == '{')
3315                 PL_tokenbuf[0] = '%';
3316
3317             /* Warn about @ where they meant $. */
3318             if (ckWARN(WARN_SYNTAX)) {
3319                 if (*s == '[' || *s == '{') {
3320                     char *t = s + 1;
3321                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
3322                         t++;
3323                     if (*t == '}' || *t == ']') {
3324                         t++;
3325                         PL_bufptr = skipspace(PL_bufptr);
3326                         Perl_warner(aTHX_ WARN_SYNTAX,
3327                             "Scalar value %.*s better written as $%.*s",
3328                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3329                     }
3330                 }
3331             }
3332         }
3333         PL_pending_ident = '@';
3334         TERM('@');
3335
3336     case '/':                   /* may either be division or pattern */
3337     case '?':                   /* may either be conditional or pattern */
3338         if (PL_expect != XOPERATOR) {
3339             /* Disable warning on "study /blah/" */
3340             if (PL_oldoldbufptr == PL_last_uni
3341                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3342                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
3343                 check_uni();
3344             s = scan_pat(s,OP_MATCH);
3345             TERM(sublex_start());
3346         }
3347         tmp = *s++;
3348         if (tmp == '/')
3349             Mop(OP_DIVIDE);
3350         OPERATOR(tmp);
3351
3352     case '.':
3353         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3354 #ifdef PERL_STRICT_CR
3355             && s[1] == '\n'
3356 #else
3357             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3358 #endif
3359             && (s == PL_linestart || s[-1] == '\n') )
3360         {
3361             PL_lex_formbrack = 0;
3362             PL_expect = XSTATE;
3363             goto rightbracket;
3364         }
3365         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3366             tmp = *s++;
3367             if (*s == tmp) {
3368                 s++;
3369                 if (*s == tmp) {
3370                     s++;
3371                     yylval.ival = OPf_SPECIAL;
3372                 }
3373                 else
3374                     yylval.ival = 0;
3375                 OPERATOR(DOTDOT);
3376             }
3377             if (PL_expect != XOPERATOR)
3378                 check_uni();
3379             Aop(OP_CONCAT);
3380         }
3381         /* FALL THROUGH */
3382     case '0': case '1': case '2': case '3': case '4':
3383     case '5': case '6': case '7': case '8': case '9':
3384         s = scan_num(s);
3385         if (PL_expect == XOPERATOR)
3386             no_op("Number",s);
3387         TERM(THING);
3388
3389     case '\'':
3390         s = scan_str(s,FALSE,FALSE);
3391         if (PL_expect == XOPERATOR) {
3392             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3393                 PL_expect = XTERM;
3394                 depcom();
3395                 return ',';     /* grandfather non-comma-format format */
3396             }
3397             else
3398                 no_op("String",s);
3399         }
3400         if (!s)
3401             missingterm((char*)0);
3402         yylval.ival = OP_CONST;
3403         TERM(sublex_start());
3404
3405     case '"':
3406         s = scan_str(s,FALSE,FALSE);
3407         if (PL_expect == XOPERATOR) {
3408             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3409                 PL_expect = XTERM;
3410                 depcom();
3411                 return ',';     /* grandfather non-comma-format format */
3412             }
3413             else
3414                 no_op("String",s);
3415         }
3416         if (!s)
3417             missingterm((char*)0);
3418         yylval.ival = OP_CONST;
3419         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3420             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3421                 yylval.ival = OP_STRINGIFY;
3422                 break;
3423             }
3424         }
3425         TERM(sublex_start());
3426
3427     case '`':
3428         s = scan_str(s,FALSE,FALSE);
3429         if (PL_expect == XOPERATOR)
3430             no_op("Backticks",s);
3431         if (!s)
3432             missingterm((char*)0);
3433         yylval.ival = OP_BACKTICK;
3434         set_csh();
3435         TERM(sublex_start());
3436
3437     case '\\':
3438         s++;
3439         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3440             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3441                         *s, *s);
3442         if (PL_expect == XOPERATOR)
3443             no_op("Backslash",s);
3444         OPERATOR(REFGEN);
3445
3446     case 'v':
3447         if (isDIGIT(s[1]) && PL_expect == XTERM) {
3448             char *start = s;
3449             start++;
3450             start++;
3451             while (isDIGIT(*start))
3452                 start++;
3453             if (*start == '.' && isDIGIT(start[1])) {
3454                 s = scan_num(s);
3455                 TERM(THING);
3456             }
3457         }
3458         goto keylookup;
3459     case 'x':
3460         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3461             s++;
3462             Mop(OP_REPEAT);
3463         }
3464         goto keylookup;
3465
3466     case '_':
3467     case 'a': case 'A':
3468     case 'b': case 'B':
3469     case 'c': case 'C':
3470     case 'd': case 'D':
3471     case 'e': case 'E':
3472     case 'f': case 'F':
3473     case 'g': case 'G':
3474     case 'h': case 'H':
3475     case 'i': case 'I':
3476     case 'j': case 'J':
3477     case 'k': case 'K':
3478     case 'l': case 'L':
3479     case 'm': case 'M':
3480     case 'n': case 'N':
3481     case 'o': case 'O':
3482     case 'p': case 'P':
3483     case 'q': case 'Q':
3484     case 'r': case 'R':
3485     case 's': case 'S':
3486     case 't': case 'T':
3487     case 'u': case 'U':
3488               case 'V':
3489     case 'w': case 'W':
3490               case 'X':
3491     case 'y': case 'Y':
3492     case 'z': case 'Z':
3493
3494       keylookup: {
3495         STRLEN n_a;
3496         gv = Nullgv;
3497         gvp = 0;
3498
3499         PL_bufptr = s;
3500         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3501
3502         /* Some keywords can be followed by any delimiter, including ':' */
3503         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3504                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3505                             (PL_tokenbuf[0] == 'q' &&
3506                              strchr("qwxr", PL_tokenbuf[1]))));
3507
3508         /* x::* is just a word, unless x is "CORE" */
3509         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3510             goto just_a_word;
3511
3512         d = s;
3513         while (d < PL_bufend && isSPACE(*d))
3514                 d++;    /* no comments skipped here, or s### is misparsed */
3515
3516         /* Is this a label? */
3517         if (!tmp && PL_expect == XSTATE
3518               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3519             s = d + 1;
3520             yylval.pval = savepv(PL_tokenbuf);
3521             CLINE;
3522             TOKEN(LABEL);
3523         }
3524
3525         /* Check for keywords */
3526         tmp = keyword(PL_tokenbuf, len);
3527
3528         /* Is this a word before a => operator? */
3529         if (strnEQ(d,"=>",2)) {
3530             CLINE;
3531             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3532             yylval.opval->op_private = OPpCONST_BARE;
3533             TERM(WORD);
3534         }
3535
3536         if (tmp < 0) {                  /* second-class keyword? */
3537             GV *ogv = Nullgv;   /* override (winner) */
3538             GV *hgv = Nullgv;   /* hidden (loser) */
3539             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3540                 CV *cv;
3541                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3542                     (cv = GvCVu(gv)))
3543                 {
3544                     if (GvIMPORTED_CV(gv))
3545                         ogv = gv;
3546                     else if (! CvMETHOD(cv))
3547                         hgv = gv;
3548                 }
3549                 if (!ogv &&
3550                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3551                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3552                     GvCVu(gv) && GvIMPORTED_CV(gv))
3553                 {
3554                     ogv = gv;
3555                 }
3556             }
3557             if (ogv) {
3558                 tmp = 0;                /* overridden by import or by GLOBAL */
3559             }
3560             else if (gv && !gvp
3561                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3562                      && GvCVu(gv)
3563                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3564             {
3565                 tmp = 0;                /* any sub overrides "weak" keyword */
3566             }
3567             else {                      /* no override */
3568                 tmp = -tmp;
3569                 gv = Nullgv;
3570                 gvp = 0;
3571                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3572                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3573                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3574                         "Ambiguous call resolved as CORE::%s(), %s",
3575                          GvENAME(hgv), "qualify as such or use &");
3576             }
3577         }
3578
3579       reserved_word:
3580         switch (tmp) {
3581
3582         default:                        /* not a keyword */
3583           just_a_word: {
3584                 SV *sv;
3585                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3586
3587                 /* Get the rest if it looks like a package qualifier */
3588
3589                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3590                     STRLEN morelen;
3591                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3592                                   TRUE, &morelen);
3593                     if (!morelen)
3594                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3595                                 *s == '\'' ? "'" : "::");
3596                     len += morelen;
3597                 }
3598
3599                 if (PL_expect == XOPERATOR) {
3600                     if (PL_bufptr == PL_linestart) {
3601                         CopLINE_dec(PL_curcop);
3602                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3603                         CopLINE_inc(PL_curcop);
3604                     }
3605                     else
3606                         no_op("Bareword",s);
3607                 }
3608
3609                 /* Look for a subroutine with this name in current package,
3610                    unless name is "Foo::", in which case Foo is a bearword
3611                    (and a package name). */
3612
3613                 if (len > 2 &&
3614                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3615                 {
3616                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3617                         Perl_warner(aTHX_ WARN_UNSAFE,
3618                             "Bareword \"%s\" refers to nonexistent package",
3619                              PL_tokenbuf);
3620                     len -= 2;
3621                     PL_tokenbuf[len] = '\0';
3622                     gv = Nullgv;
3623                     gvp = 0;
3624                 }
3625                 else {
3626                     len = 0;
3627                     if (!gv)
3628                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3629                 }
3630
3631                 /* if we saw a global override before, get the right name */
3632
3633                 if (gvp) {
3634                     sv = newSVpvn("CORE::GLOBAL::",14);
3635                     sv_catpv(sv,PL_tokenbuf);
3636                 }
3637                 else
3638                     sv = newSVpv(PL_tokenbuf,0);
3639
3640                 /* Presume this is going to be a bareword of some sort. */
3641
3642                 CLINE;
3643                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3644                 yylval.opval->op_private = OPpCONST_BARE;
3645
3646                 /* And if "Foo::", then that's what it certainly is. */
3647
3648                 if (len)
3649                     goto safe_bareword;
3650
3651                 /* See if it's the indirect object for a list operator. */
3652
3653                 if (PL_oldoldbufptr &&
3654                     PL_oldoldbufptr < PL_bufptr &&
3655                     (PL_oldoldbufptr == PL_last_lop
3656                      || PL_oldoldbufptr == PL_last_uni) &&
3657                     /* NO SKIPSPACE BEFORE HERE! */
3658                     (PL_expect == XREF ||
3659                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3660                 {
3661                     bool immediate_paren = *s == '(';
3662
3663                     /* (Now we can afford to cross potential line boundary.) */
3664                     s = skipspace(s);
3665
3666                     /* Two barewords in a row may indicate method call. */
3667
3668                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3669                         return tmp;
3670
3671                     /* If not a declared subroutine, it's an indirect object. */
3672                     /* (But it's an indir obj regardless for sort.) */
3673
3674                     if ((PL_last_lop_op == OP_SORT ||
3675                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3676                         (PL_last_lop_op != OP_MAPSTART &&
3677                          PL_last_lop_op != OP_GREPSTART))
3678                     {
3679                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3680                         goto bareword;
3681                     }
3682                 }
3683
3684                 /* If followed by a paren, it's certainly a subroutine. */
3685
3686                 PL_expect = XOPERATOR;
3687                 s = skipspace(s);
3688                 if (*s == '(') {
3689                     CLINE;
3690                     if (gv && GvCVu(gv)) {
3691                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3692                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3693                             s = d + 1;
3694                             goto its_constant;
3695                         }
3696                     }
3697                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3698                     PL_expect = XOPERATOR;
3699                     force_next(WORD);
3700                     yylval.ival = 0;
3701                     TOKEN('&');
3702                 }
3703
3704                 /* If followed by var or block, call it a method (unless sub) */
3705
3706                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3707                     PL_last_lop = PL_oldbufptr;
3708                     PL_last_lop_op = OP_METHOD;
3709                     PREBLOCK(METHOD);
3710                 }
3711
3712                 /* If followed by a bareword, see if it looks like indir obj. */
3713
3714                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3715                     return tmp;
3716
3717                 /* Not a method, so call it a subroutine (if defined) */
3718
3719                 if (gv && GvCVu(gv)) {
3720                     CV* cv;
3721                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3722                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3723                                 "Ambiguous use of -%s resolved as -&%s()",
3724                                 PL_tokenbuf, PL_tokenbuf);
3725                     /* Check for a constant sub */
3726                     cv = GvCV(gv);
3727                     if ((sv = cv_const_sv(cv))) {
3728                   its_constant:
3729                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3730                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3731                         yylval.opval->op_private = 0;
3732                         TOKEN(WORD);
3733                     }
3734
3735                     /* Resolve to GV now. */
3736                     op_free(yylval.opval);
3737                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3738                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3739                     PL_last_lop = PL_oldbufptr;
3740                     PL_last_lop_op = OP_ENTERSUB;
3741                     /* Is there a prototype? */
3742                     if (SvPOK(cv)) {
3743                         STRLEN len;
3744                         char *proto = SvPV((SV*)cv, len);
3745                         if (!len)
3746                             TERM(FUNC0SUB);
3747                         if (strEQ(proto, "$"))
3748                             OPERATOR(UNIOPSUB);
3749                         if (*proto == '&' && *s == '{') {
3750                             sv_setpv(PL_subname,"__ANON__");
3751                             PREBLOCK(LSTOPSUB);
3752                         }
3753                     }
3754                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3755                     PL_expect = XTERM;
3756                     force_next(WORD);
3757                     TOKEN(NOAMP);
3758                 }
3759
3760                 /* Call it a bare word */
3761
3762                 if (PL_hints & HINT_STRICT_SUBS)
3763                     yylval.opval->op_private |= OPpCONST_STRICT;
3764                 else {
3765                 bareword:
3766                     if (ckWARN(WARN_RESERVED)) {
3767                         if (lastchar != '-') {
3768                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3769                             if (!*d)
3770                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3771                                        PL_tokenbuf);
3772                         }
3773                     }
3774                 }
3775
3776             safe_bareword:
3777                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3778                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3779                         "Operator or semicolon missing before %c%s",
3780                         lastchar, PL_tokenbuf);
3781                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3782                         "Ambiguous use of %c resolved as operator %c",
3783                         lastchar, lastchar);
3784                 }
3785                 TOKEN(WORD);
3786             }
3787
3788         case KEY___FILE__:
3789             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3790                                         newSVpv(CopFILE(PL_curcop),0));
3791             TERM(THING);
3792
3793         case KEY___LINE__:
3794             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3795                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3796             TERM(THING);
3797
3798         case KEY___PACKAGE__:
3799             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3800                                         (PL_curstash
3801                                          ? newSVsv(PL_curstname)
3802                                          : &PL_sv_undef));
3803             TERM(THING);
3804
3805         case KEY___DATA__:
3806         case KEY___END__: {
3807             GV *gv;
3808
3809             /*SUPPRESS 560*/
3810             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3811                 char *pname = "main";
3812                 if (PL_tokenbuf[2] == 'D')
3813                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3814                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3815                 GvMULTI_on(gv);
3816                 if (!GvIO(gv))
3817                     GvIOp(gv) = newIO();
3818                 IoIFP(GvIOp(gv)) = PL_rsfp;
3819 #if defined(HAS_FCNTL) && defined(F_SETFD)
3820                 {
3821                     int fd = PerlIO_fileno(PL_rsfp);
3822                     fcntl(fd,F_SETFD,fd >= 3);
3823                 }
3824 #endif
3825                 /* Mark this internal pseudo-handle as clean */
3826                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3827                 if (PL_preprocess)
3828                     IoTYPE(GvIOp(gv)) = '|';
3829                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3830                     IoTYPE(GvIOp(gv)) = '-';
3831                 else
3832                     IoTYPE(GvIOp(gv)) = '<';
3833 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3834                 /* if the script was opened in binmode, we need to revert
3835                  * it to text mode for compatibility; but only iff it has CRs
3836                  * XXX this is a questionable hack at best. */
3837                 if (PL_bufend-PL_bufptr > 2
3838                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3839                 {
3840                     Off_t loc = 0;
3841                     if (IoTYPE(GvIOp(gv)) == '<') {
3842                         loc = PerlIO_tell(PL_rsfp);
3843                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
3844                     }
3845                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3846 #if defined(__BORLANDC__)
3847                         /* XXX see note in do_binmode() */
3848                         ((FILE*)PL_rsfp)->flags |= _F_BIN;
3849 #endif
3850                         if (loc > 0)
3851                             PerlIO_seek(PL_rsfp, loc, 0);
3852                     }
3853                 }
3854 #endif
3855                 PL_rsfp = Nullfp;
3856             }
3857             goto fake_eof;
3858         }
3859
3860         case KEY_AUTOLOAD:
3861         case KEY_DESTROY:
3862         case KEY_BEGIN:
3863         case KEY_CHECK:
3864         case KEY_INIT:
3865         case KEY_END:
3866             if (PL_expect == XSTATE) {
3867                 s = PL_bufptr;
3868                 goto really_sub;
3869             }
3870             goto just_a_word;
3871
3872         case KEY_CORE:
3873             if (*s == ':' && s[1] == ':') {
3874                 s += 2;
3875                 d = s;
3876                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3877                 tmp = keyword(PL_tokenbuf, len);
3878                 if (tmp < 0)
3879                     tmp = -tmp;
3880                 goto reserved_word;
3881             }
3882             goto just_a_word;
3883
3884         case KEY_abs:
3885             UNI(OP_ABS);
3886
3887         case KEY_alarm:
3888             UNI(OP_ALARM);
3889
3890         case KEY_accept:
3891             LOP(OP_ACCEPT,XTERM);
3892
3893         case KEY_and:
3894             OPERATOR(ANDOP);
3895
3896         case KEY_atan2:
3897             LOP(OP_ATAN2,XTERM);
3898
3899         case KEY_bind:
3900             LOP(OP_BIND,XTERM);
3901
3902         case KEY_binmode:
3903             UNI(OP_BINMODE);
3904
3905         case KEY_bless:
3906             LOP(OP_BLESS,XTERM);
3907
3908         case KEY_chop:
3909             UNI(OP_CHOP);
3910
3911         case KEY_continue:
3912             PREBLOCK(CONTINUE);
3913
3914         case KEY_chdir:
3915             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3916             UNI(OP_CHDIR);
3917
3918         case KEY_close:
3919             UNI(OP_CLOSE);
3920
3921         case KEY_closedir:
3922             UNI(OP_CLOSEDIR);
3923
3924         case KEY_cmp:
3925             Eop(OP_SCMP);
3926
3927         case KEY_caller:
3928             UNI(OP_CALLER);
3929
3930         case KEY_crypt:
3931 #ifdef FCRYPT
3932             if (!PL_cryptseen) {
3933                 PL_cryptseen = TRUE;
3934                 init_des();
3935             }
3936 #endif
3937             LOP(OP_CRYPT,XTERM);
3938
3939         case KEY_chmod:
3940             if (ckWARN(WARN_OCTAL)) {
3941                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3942                 if (*d != '0' && isDIGIT(*d))
3943                     Perl_warner(aTHX_ WARN_OCTAL,
3944                                 "chmod: mode argument is missing initial 0");
3945             }
3946             LOP(OP_CHMOD,XTERM);
3947
3948         case KEY_chown:
3949             LOP(OP_CHOWN,XTERM);
3950
3951         case KEY_connect:
3952             LOP(OP_CONNECT,XTERM);
3953
3954         case KEY_chr:
3955             UNI(OP_CHR);
3956
3957         case KEY_cos:
3958             UNI(OP_COS);
3959
3960         case KEY_chroot:
3961             UNI(OP_CHROOT);
3962
3963         case KEY_do:
3964             s = skipspace(s);
3965             if (*s == '{')
3966                 PRETERMBLOCK(DO);
3967             if (*s != '\'')
3968                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3969             OPERATOR(DO);
3970
3971         case KEY_die:
3972             PL_hints |= HINT_BLOCK_SCOPE;
3973             LOP(OP_DIE,XTERM);
3974
3975         case KEY_defined:
3976             UNI(OP_DEFINED);
3977
3978         case KEY_delete:
3979             UNI(OP_DELETE);
3980
3981         case KEY_dbmopen:
3982             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3983             LOP(OP_DBMOPEN,XTERM);
3984
3985         case KEY_dbmclose:
3986             UNI(OP_DBMCLOSE);
3987
3988         case KEY_dump:
3989             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3990             LOOPX(OP_DUMP);
3991
3992         case KEY_else:
3993             PREBLOCK(ELSE);
3994
3995         case KEY_elsif:
3996             yylval.ival = CopLINE(PL_curcop);
3997             OPERATOR(ELSIF);
3998
3999         case KEY_eq:
4000             Eop(OP_SEQ);
4001
4002         case KEY_exists:
4003             UNI(OP_EXISTS);
4004
4005         case KEY_exit:
4006             UNI(OP_EXIT);
4007
4008         case KEY_eval:
4009             s = skipspace(s);
4010             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4011             UNIBRACK(OP_ENTEREVAL);
4012
4013         case KEY_eof:
4014             UNI(OP_EOF);
4015
4016         case KEY_exp:
4017             UNI(OP_EXP);
4018
4019         case KEY_each:
4020             UNI(OP_EACH);
4021
4022         case KEY_exec:
4023             set_csh();
4024             LOP(OP_EXEC,XREF);
4025
4026         case KEY_endhostent:
4027             FUN0(OP_EHOSTENT);
4028
4029         case KEY_endnetent:
4030             FUN0(OP_ENETENT);
4031
4032         case KEY_endservent:
4033             FUN0(OP_ESERVENT);
4034
4035         case KEY_endprotoent:
4036             FUN0(OP_EPROTOENT);
4037
4038         case KEY_endpwent:
4039             FUN0(OP_EPWENT);
4040
4041         case KEY_endgrent:
4042             FUN0(OP_EGRENT);
4043
4044         case KEY_for:
4045         case KEY_foreach:
4046             yylval.ival = CopLINE(PL_curcop);
4047             s = skipspace(s);
4048             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
4049                 char *p = s;
4050                 if ((PL_bufend - p) >= 3 &&
4051                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4052                     p += 2;
4053                 else if ((PL_bufend - p) >= 4 &&
4054                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4055                     p += 3;
4056                 p = skipspace(p);
4057                 if (isIDFIRST_lazy(p)) {
4058                     p = scan_ident(p, PL_bufend,
4059                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4060                     p = skipspace(p);
4061                 }
4062                 if (*p != '$')
4063                     Perl_croak(aTHX_ "Missing $ on loop variable");
4064             }
4065             OPERATOR(FOR);
4066
4067         case KEY_formline:
4068             LOP(OP_FORMLINE,XTERM);
4069
4070         case KEY_fork:
4071             FUN0(OP_FORK);
4072
4073         case KEY_fcntl:
4074             LOP(OP_FCNTL,XTERM);
4075
4076         case KEY_fileno:
4077             UNI(OP_FILENO);
4078
4079         case KEY_flock:
4080             LOP(OP_FLOCK,XTERM);
4081
4082         case KEY_gt:
4083             Rop(OP_SGT);
4084
4085         case KEY_ge:
4086             Rop(OP_SGE);
4087
4088         case KEY_grep:
4089             LOP(OP_GREPSTART, XREF);
4090
4091         case KEY_goto:
4092             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4093             LOOPX(OP_GOTO);
4094
4095         case KEY_gmtime:
4096             UNI(OP_GMTIME);
4097
4098         case KEY_getc:
4099             UNI(OP_GETC);
4100
4101         case KEY_getppid:
4102             FUN0(OP_GETPPID);
4103
4104         case KEY_getpgrp:
4105             UNI(OP_GETPGRP);
4106
4107         case KEY_getpriority:
4108             LOP(OP_GETPRIORITY,XTERM);
4109
4110         case KEY_getprotobyname:
4111             UNI(OP_GPBYNAME);
4112
4113         case KEY_getprotobynumber:
4114             LOP(OP_GPBYNUMBER,XTERM);
4115
4116         case KEY_getprotoent:
4117             FUN0(OP_GPROTOENT);
4118
4119         case KEY_getpwent:
4120             FUN0(OP_GPWENT);
4121
4122         case KEY_getpwnam:
4123             UNI(OP_GPWNAM);
4124
4125         case KEY_getpwuid:
4126             UNI(OP_GPWUID);
4127
4128         case KEY_getpeername:
4129             UNI(OP_GETPEERNAME);
4130
4131         case KEY_gethostbyname:
4132             UNI(OP_GHBYNAME);
4133
4134         case KEY_gethostbyaddr:
4135             LOP(OP_GHBYADDR,XTERM);
4136
4137         case KEY_gethostent:
4138             FUN0(OP_GHOSTENT);
4139
4140         case KEY_getnetbyname:
4141             UNI(OP_GNBYNAME);
4142
4143         case KEY_getnetbyaddr:
4144             LOP(OP_GNBYADDR,XTERM);
4145
4146         case KEY_getnetent:
4147             FUN0(OP_GNETENT);
4148
4149         case KEY_getservbyname:
4150             LOP(OP_GSBYNAME,XTERM);
4151
4152         case KEY_getservbyport:
4153             LOP(OP_GSBYPORT,XTERM);
4154
4155         case KEY_getservent:
4156             FUN0(OP_GSERVENT);
4157
4158         case KEY_getsockname:
4159             UNI(OP_GETSOCKNAME);
4160
4161         case KEY_getsockopt:
4162             LOP(OP_GSOCKOPT,XTERM);
4163
4164         case KEY_getgrent:
4165             FUN0(OP_GGRENT);
4166
4167         case KEY_getgrnam:
4168             UNI(OP_GGRNAM);
4169
4170         case KEY_getgrgid:
4171             UNI(OP_GGRGID);
4172
4173         case KEY_getlogin:
4174             FUN0(OP_GETLOGIN);
4175
4176         case KEY_glob:
4177             set_csh();
4178             LOP(OP_GLOB,XTERM);
4179
4180         case KEY_hex:
4181             UNI(OP_HEX);
4182
4183         case KEY_if:
4184             yylval.ival = CopLINE(PL_curcop);
4185             OPERATOR(IF);
4186
4187         case KEY_index:
4188             LOP(OP_INDEX,XTERM);
4189
4190         case KEY_int:
4191             UNI(OP_INT);
4192
4193         case KEY_ioctl:
4194             LOP(OP_IOCTL,XTERM);
4195
4196         case KEY_join:
4197             LOP(OP_JOIN,XTERM);
4198
4199         case KEY_keys:
4200             UNI(OP_KEYS);
4201
4202         case KEY_kill:
4203             LOP(OP_KILL,XTERM);
4204
4205         case KEY_last:
4206             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4207             LOOPX(OP_LAST);
4208
4209         case KEY_lc:
4210             UNI(OP_LC);
4211
4212         case KEY_lcfirst:
4213             UNI(OP_LCFIRST);
4214
4215         case KEY_local:
4216             yylval.ival = 0;
4217             OPERATOR(LOCAL);
4218
4219         case KEY_length:
4220             UNI(OP_LENGTH);
4221
4222         case KEY_lt:
4223             Rop(OP_SLT);
4224
4225         case KEY_le:
4226             Rop(OP_SLE);
4227
4228         case KEY_localtime:
4229             UNI(OP_LOCALTIME);
4230
4231         case KEY_log:
4232             UNI(OP_LOG);
4233
4234         case KEY_link:
4235             LOP(OP_LINK,XTERM);
4236
4237         case KEY_listen:
4238             LOP(OP_LISTEN,XTERM);
4239
4240         case KEY_lock:
4241             UNI(OP_LOCK);
4242
4243         case KEY_lstat:
4244             UNI(OP_LSTAT);
4245
4246         case KEY_m:
4247             s = scan_pat(s,OP_MATCH);
4248             TERM(sublex_start());
4249
4250         case KEY_map:
4251             LOP(OP_MAPSTART, XREF);
4252
4253         case KEY_mkdir:
4254             LOP(OP_MKDIR,XTERM);
4255
4256         case KEY_msgctl:
4257             LOP(OP_MSGCTL,XTERM);
4258
4259         case KEY_msgget:
4260             LOP(OP_MSGGET,XTERM);
4261
4262         case KEY_msgrcv:
4263             LOP(OP_MSGRCV,XTERM);
4264
4265         case KEY_msgsnd:
4266             LOP(OP_MSGSND,XTERM);
4267
4268         case KEY_our:
4269         case KEY_my:
4270             PL_in_my = tmp;
4271             s = skipspace(s);
4272             if (isIDFIRST_lazy(s)) {
4273                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4274                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4275                     goto really_sub;
4276                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4277                 if (!PL_in_my_stash) {
4278                     char tmpbuf[1024];
4279                     PL_bufptr = s;
4280                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4281                     yyerror(tmpbuf);
4282                 }
4283             }
4284             yylval.ival = 1;
4285             OPERATOR(MY);
4286
4287         case KEY_next:
4288             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4289             LOOPX(OP_NEXT);
4290
4291         case KEY_ne:
4292             Eop(OP_SNE);
4293
4294         case KEY_no:
4295             if (PL_expect != XSTATE)
4296                 yyerror("\"no\" not allowed in expression");
4297             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4298             s = force_version(s);
4299             yylval.ival = 0;
4300             OPERATOR(USE);
4301
4302         case KEY_not:
4303             if (*s == '(' || (s = skipspace(s), *s == '('))
4304                 FUN1(OP_NOT);
4305             else
4306                 OPERATOR(NOTOP);
4307
4308         case KEY_open:
4309             s = skipspace(s);
4310             if (isIDFIRST_lazy(s)) {
4311                 char *t;
4312                 for (d = s; isALNUM_lazy(d); d++) ;
4313                 t = skipspace(d);
4314                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
4315                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4316                            "Precedence problem: open %.*s should be open(%.*s)",
4317                             d-s,s, d-s,s);
4318             }
4319             LOP(OP_OPEN,XTERM);
4320
4321         case KEY_or:
4322             yylval.ival = OP_OR;
4323             OPERATOR(OROP);
4324
4325         case KEY_ord:
4326             UNI(OP_ORD);
4327
4328         case KEY_oct:
4329             UNI(OP_OCT);
4330
4331         case KEY_opendir:
4332             LOP(OP_OPEN_DIR,XTERM);
4333
4334         case KEY_print:
4335             checkcomma(s,PL_tokenbuf,"filehandle");
4336             LOP(OP_PRINT,XREF);
4337
4338         case KEY_printf:
4339             checkcomma(s,PL_tokenbuf,"filehandle");
4340             LOP(OP_PRTF,XREF);
4341
4342         case KEY_prototype:
4343             UNI(OP_PROTOTYPE);
4344
4345         case KEY_push:
4346             LOP(OP_PUSH,XTERM);
4347
4348         case KEY_pop:
4349             UNI(OP_POP);
4350
4351         case KEY_pos:
4352             UNI(OP_POS);
4353
4354         case KEY_pack:
4355             LOP(OP_PACK,XTERM);
4356
4357         case KEY_package:
4358             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4359             OPERATOR(PACKAGE);
4360
4361         case KEY_pipe:
4362             LOP(OP_PIPE_OP,XTERM);
4363
4364         case KEY_q:
4365             s = scan_str(s,FALSE,FALSE);
4366             if (!s)
4367                 missingterm((char*)0);
4368             yylval.ival = OP_CONST;
4369             TERM(sublex_start());
4370
4371         case KEY_quotemeta:
4372             UNI(OP_QUOTEMETA);
4373
4374         case KEY_qw:
4375             s = scan_str(s,FALSE,FALSE);
4376             if (!s)
4377                 missingterm((char*)0);
4378             force_next(')');
4379             if (SvCUR(PL_lex_stuff)) {
4380                 OP *words = Nullop;
4381                 int warned = 0;
4382                 d = SvPV_force(PL_lex_stuff, len);
4383                 while (len) {
4384                     for (; isSPACE(*d) && len; --len, ++d) ;
4385                     if (len) {
4386                         char *b = d;
4387                         if (!warned && ckWARN(WARN_SYNTAX)) {
4388                             for (; !isSPACE(*d) && len; --len, ++d) {
4389                                 if (*d == ',') {
4390                                     Perl_warner(aTHX_ WARN_SYNTAX,
4391                                         "Possible attempt to separate words with commas");
4392                                     ++warned;
4393                                 }
4394                                 else if (*d == '#') {
4395                                     Perl_warner(aTHX_ WARN_SYNTAX,
4396                                         "Possible attempt to put comments in qw() list");
4397                                     ++warned;
4398                                 }
4399                             }
4400                         }
4401                         else {
4402                             for (; !isSPACE(*d) && len; --len, ++d) ;
4403                         }
4404                         words = append_elem(OP_LIST, words,
4405                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
4406                     }
4407                 }
4408                 if (words) {
4409                     PL_nextval[PL_nexttoke].opval = words;
4410                     force_next(THING);
4411                 }
4412             }
4413             if (PL_lex_stuff)
4414                 SvREFCNT_dec(PL_lex_stuff);
4415             PL_lex_stuff = Nullsv;
4416             PL_expect = XTERM;
4417             TOKEN('(');
4418
4419         case KEY_qq:
4420             s = scan_str(s,FALSE,FALSE);
4421             if (!s)
4422                 missingterm((char*)0);
4423             yylval.ival = OP_STRINGIFY;
4424             if (SvIVX(PL_lex_stuff) == '\'')
4425                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4426             TERM(sublex_start());
4427
4428         case KEY_qr:
4429             s = scan_pat(s,OP_QR);
4430             TERM(sublex_start());
4431
4432         case KEY_qx:
4433             s = scan_str(s,FALSE,FALSE);
4434             if (!s)
4435                 missingterm((char*)0);
4436             yylval.ival = OP_BACKTICK;
4437             set_csh();
4438             TERM(sublex_start());
4439
4440         case KEY_return:
4441             OLDLOP(OP_RETURN);
4442
4443         case KEY_require:
4444             s = skipspace(s);
4445             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4446                 s = force_version(s);
4447             }
4448             else {
4449                 *PL_tokenbuf = '\0';
4450                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4451                 if (isIDFIRST_lazy(PL_tokenbuf))
4452                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4453                 else if (*s == '<')
4454                     yyerror("<> should be quotes");
4455             }
4456             UNI(OP_REQUIRE);
4457
4458         case KEY_reset:
4459             UNI(OP_RESET);
4460
4461         case KEY_redo:
4462             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4463             LOOPX(OP_REDO);
4464
4465         case KEY_rename:
4466             LOP(OP_RENAME,XTERM);
4467
4468         case KEY_rand:
4469             UNI(OP_RAND);
4470
4471         case KEY_rmdir:
4472             UNI(OP_RMDIR);
4473
4474         case KEY_rindex:
4475             LOP(OP_RINDEX,XTERM);
4476
4477         case KEY_read:
4478             LOP(OP_READ,XTERM);
4479
4480         case KEY_readdir:
4481             UNI(OP_READDIR);
4482
4483         case KEY_readline:
4484             set_csh();
4485             UNI(OP_READLINE);
4486
4487         case KEY_readpipe:
4488             set_csh();
4489             UNI(OP_BACKTICK);
4490
4491         case KEY_rewinddir:
4492             UNI(OP_REWINDDIR);
4493
4494         case KEY_recv:
4495             LOP(OP_RECV,XTERM);
4496
4497         case KEY_reverse:
4498             LOP(OP_REVERSE,XTERM);
4499
4500         case KEY_readlink:
4501             UNI(OP_READLINK);
4502
4503         case KEY_ref:
4504             UNI(OP_REF);
4505
4506         case KEY_s:
4507             s = scan_subst(s);
4508             if (yylval.opval)
4509                 TERM(sublex_start());
4510             else
4511                 TOKEN(1);       /* force error */
4512
4513         case KEY_chomp:
4514             UNI(OP_CHOMP);
4515
4516         case KEY_scalar:
4517             UNI(OP_SCALAR);
4518
4519         case KEY_select:
4520             LOP(OP_SELECT,XTERM);
4521
4522         case KEY_seek:
4523             LOP(OP_SEEK,XTERM);
4524
4525         case KEY_semctl:
4526             LOP(OP_SEMCTL,XTERM);
4527
4528         case KEY_semget:
4529             LOP(OP_SEMGET,XTERM);
4530
4531         case KEY_semop:
4532             LOP(OP_SEMOP,XTERM);
4533
4534         case KEY_send:
4535             LOP(OP_SEND,XTERM);
4536
4537         case KEY_setpgrp:
4538             LOP(OP_SETPGRP,XTERM);
4539
4540         case KEY_setpriority:
4541             LOP(OP_SETPRIORITY,XTERM);
4542
4543         case KEY_sethostent:
4544             UNI(OP_SHOSTENT);
4545
4546         case KEY_setnetent:
4547             UNI(OP_SNETENT);
4548
4549         case KEY_setservent:
4550             UNI(OP_SSERVENT);
4551
4552         case KEY_setprotoent:
4553             UNI(OP_SPROTOENT);
4554
4555         case KEY_setpwent:
4556             FUN0(OP_SPWENT);
4557
4558         case KEY_setgrent:
4559             FUN0(OP_SGRENT);
4560
4561         case KEY_seekdir:
4562             LOP(OP_SEEKDIR,XTERM);
4563
4564         case KEY_setsockopt:
4565             LOP(OP_SSOCKOPT,XTERM);
4566
4567         case KEY_shift:
4568             UNI(OP_SHIFT);
4569
4570         case KEY_shmctl:
4571             LOP(OP_SHMCTL,XTERM);
4572
4573         case KEY_shmget:
4574             LOP(OP_SHMGET,XTERM);
4575
4576         case KEY_shmread:
4577             LOP(OP_SHMREAD,XTERM);
4578
4579         case KEY_shmwrite:
4580             LOP(OP_SHMWRITE,XTERM);
4581
4582         case KEY_shutdown:
4583             LOP(OP_SHUTDOWN,XTERM);
4584
4585         case KEY_sin:
4586             UNI(OP_SIN);
4587
4588         case KEY_sleep:
4589             UNI(OP_SLEEP);
4590
4591         case KEY_socket:
4592             LOP(OP_SOCKET,XTERM);
4593
4594         case KEY_socketpair:
4595             LOP(OP_SOCKPAIR,XTERM);
4596
4597         case KEY_sort:
4598             checkcomma(s,PL_tokenbuf,"subroutine name");
4599             s = skipspace(s);
4600             if (*s == ';' || *s == ')')         /* probably a close */
4601                 Perl_croak(aTHX_ "sort is now a reserved word");
4602             PL_expect = XTERM;
4603             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4604             LOP(OP_SORT,XREF);
4605
4606         case KEY_split:
4607             LOP(OP_SPLIT,XTERM);
4608
4609         case KEY_sprintf:
4610             LOP(OP_SPRINTF,XTERM);
4611
4612         case KEY_splice:
4613             LOP(OP_SPLICE,XTERM);
4614
4615         case KEY_sqrt:
4616             UNI(OP_SQRT);
4617
4618         case KEY_srand:
4619             UNI(OP_SRAND);
4620
4621         case KEY_stat:
4622             UNI(OP_STAT);
4623
4624         case KEY_study:
4625             UNI(OP_STUDY);
4626
4627         case KEY_substr:
4628             LOP(OP_SUBSTR,XTERM);
4629
4630         case KEY_format:
4631         case KEY_sub:
4632           really_sub:
4633             {
4634                 char tmpbuf[sizeof PL_tokenbuf];
4635                 SSize_t tboffset;
4636                 expectation attrful;
4637                 bool have_name, have_proto;
4638                 int key = tmp;
4639
4640                 s = skipspace(s);
4641
4642                 if (isIDFIRST_lazy(s) || *s == '\'' ||
4643                     (*s == ':' && s[1] == ':'))
4644                 {
4645                     PL_expect = XBLOCK;
4646                     attrful = XATTRBLOCK;
4647                     /* remember buffer pos'n for later force_word */
4648                     tboffset = s - PL_oldbufptr;
4649                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4650                     if (strchr(tmpbuf, ':'))
4651                         sv_setpv(PL_subname, tmpbuf);
4652                     else {
4653                         sv_setsv(PL_subname,PL_curstname);
4654                         sv_catpvn(PL_subname,"::",2);
4655                         sv_catpvn(PL_subname,tmpbuf,len);
4656                     }
4657                     s = skipspace(d);
4658                     have_name = TRUE;
4659                 }
4660                 else {
4661                     if (key == KEY_my)
4662                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4663                     PL_expect = XTERMBLOCK;
4664                     attrful = XATTRTERM;
4665                     sv_setpv(PL_subname,"?");
4666                     have_name = FALSE;
4667                 }
4668
4669                 if (key == KEY_format) {
4670                     if (*s == '=')
4671                         PL_lex_formbrack = PL_lex_brackets + 1;
4672                     if (have_name)
4673                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4674                                           FALSE, TRUE, TRUE);
4675                     OPERATOR(FORMAT);
4676                 }
4677
4678                 /* Look for a prototype */
4679                 if (*s == '(') {
4680                     char *p;
4681
4682                     s = scan_str(s,FALSE,FALSE);
4683                     if (!s) {
4684                         if (PL_lex_stuff)
4685                             SvREFCNT_dec(PL_lex_stuff);
4686                         PL_lex_stuff = Nullsv;
4687                         Perl_croak(aTHX_ "Prototype not terminated");
4688                     }
4689                     /* strip spaces */
4690                     d = SvPVX(PL_lex_stuff);
4691                     tmp = 0;
4692                     for (p = d; *p; ++p) {
4693                         if (!isSPACE(*p))
4694                             d[tmp++] = *p;
4695                     }
4696                     d[tmp] = '\0';
4697                     SvCUR(PL_lex_stuff) = tmp;
4698                     have_proto = TRUE;
4699
4700                     s = skipspace(s);
4701                 }
4702                 else
4703                     have_proto = FALSE;
4704
4705                 if (*s == ':' && s[1] != ':')
4706                     PL_expect = attrful;
4707
4708                 if (have_proto) {
4709                     PL_nextval[PL_nexttoke].opval =
4710                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4711                     PL_lex_stuff = Nullsv;
4712                     force_next(THING);
4713                 }
4714                 if (!have_name) {
4715                     sv_setpv(PL_subname,"__ANON__");
4716                     TOKEN(ANONSUB);
4717                 }
4718                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4719                                   FALSE, TRUE, TRUE);
4720                 if (key == KEY_my)
4721                     TOKEN(MYSUB);
4722                 TOKEN(SUB);
4723             }
4724
4725         case KEY_system:
4726             set_csh();
4727             LOP(OP_SYSTEM,XREF);
4728
4729         case KEY_symlink:
4730             LOP(OP_SYMLINK,XTERM);
4731
4732         case KEY_syscall:
4733             LOP(OP_SYSCALL,XTERM);
4734
4735         case KEY_sysopen:
4736             LOP(OP_SYSOPEN,XTERM);
4737
4738         case KEY_sysseek:
4739             LOP(OP_SYSSEEK,XTERM);
4740
4741         case KEY_sysread:
4742             LOP(OP_SYSREAD,XTERM);
4743
4744         case KEY_syswrite:
4745             LOP(OP_SYSWRITE,XTERM);
4746
4747         case KEY_tr:
4748             s = scan_trans(s);
4749             TERM(sublex_start());
4750
4751         case KEY_tell:
4752             UNI(OP_TELL);
4753
4754         case KEY_telldir:
4755             UNI(OP_TELLDIR);
4756
4757         case KEY_tie:
4758             LOP(OP_TIE,XTERM);
4759
4760         case KEY_tied:
4761             UNI(OP_TIED);
4762
4763         case KEY_time:
4764             FUN0(OP_TIME);
4765
4766         case KEY_times:
4767             FUN0(OP_TMS);
4768
4769         case KEY_truncate:
4770             LOP(OP_TRUNCATE,XTERM);
4771
4772         case KEY_uc:
4773             UNI(OP_UC);
4774
4775         case KEY_ucfirst:
4776             UNI(OP_UCFIRST);
4777
4778         case KEY_untie:
4779             UNI(OP_UNTIE);
4780
4781         case KEY_until:
4782             yylval.ival = CopLINE(PL_curcop);
4783             OPERATOR(UNTIL);
4784
4785         case KEY_unless:
4786             yylval.ival = CopLINE(PL_curcop);
4787             OPERATOR(UNLESS);
4788
4789         case KEY_unlink:
4790             LOP(OP_UNLINK,XTERM);
4791
4792         case KEY_undef:
4793             UNI(OP_UNDEF);
4794
4795         case KEY_unpack:
4796             LOP(OP_UNPACK,XTERM);
4797
4798         case KEY_utime:
4799             LOP(OP_UTIME,XTERM);
4800
4801         case KEY_umask:
4802             if (ckWARN(WARN_OCTAL)) {
4803                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4804                 if (*d != '0' && isDIGIT(*d))
4805                     Perl_warner(aTHX_ WARN_OCTAL,
4806                                 "umask: argument is missing initial 0");
4807             }
4808             UNI(OP_UMASK);
4809
4810         case KEY_unshift:
4811             LOP(OP_UNSHIFT,XTERM);
4812
4813         case KEY_use:
4814             if (PL_expect != XSTATE)
4815                 yyerror("\"use\" not allowed in expression");
4816             s = skipspace(s);
4817             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4818                 s = force_version(s);
4819                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
4820                     PL_nextval[PL_nexttoke].opval = Nullop;
4821                     force_next(WORD);
4822                 }
4823             }
4824             else {
4825                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4826                 s = force_version(s);
4827             }
4828             yylval.ival = 1;
4829             OPERATOR(USE);
4830
4831         case KEY_values:
4832             UNI(OP_VALUES);
4833
4834         case KEY_vec:
4835             LOP(OP_VEC,XTERM);
4836
4837         case KEY_while:
4838             yylval.ival = CopLINE(PL_curcop);
4839             OPERATOR(WHILE);
4840
4841         case KEY_warn:
4842             PL_hints |= HINT_BLOCK_SCOPE;
4843             LOP(OP_WARN,XTERM);
4844
4845         case KEY_wait:
4846             FUN0(OP_WAIT);
4847
4848         case KEY_waitpid:
4849             LOP(OP_WAITPID,XTERM);
4850
4851         case KEY_wantarray:
4852             FUN0(OP_WANTARRAY);
4853
4854         case KEY_write:
4855 #ifdef EBCDIC
4856         {
4857             static char ctl_l[2];
4858
4859             if (ctl_l[0] == '\0')
4860                 ctl_l[0] = toCTRL('L');
4861             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4862         }
4863 #else
4864             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4865 #endif
4866             UNI(OP_ENTERWRITE);
4867
4868         case KEY_x:
4869             if (PL_expect == XOPERATOR)
4870                 Mop(OP_REPEAT);
4871             check_uni();
4872             goto just_a_word;
4873
4874         case KEY_xor:
4875             yylval.ival = OP_XOR;
4876             OPERATOR(OROP);
4877
4878         case KEY_y:
4879             s = scan_trans(s);
4880             TERM(sublex_start());
4881         }
4882     }}
4883 }
4884
4885 I32
4886 Perl_keyword(pTHX_ register char *d, I32 len)
4887 {
4888     switch (*d) {
4889     case '_':
4890         if (d[1] == '_') {
4891             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4892             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4893             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4894             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4895             if (strEQ(d,"__END__"))             return KEY___END__;
4896         }
4897         break;
4898     case 'A':
4899         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4900         break;
4901     case 'a':
4902         switch (len) {
4903         case 3:
4904             if (strEQ(d,"and"))                 return -KEY_and;
4905             if (strEQ(d,"abs"))                 return -KEY_abs;
4906             break;
4907         case 5:
4908             if (strEQ(d,"alarm"))               return -KEY_alarm;
4909             if (strEQ(d,"atan2"))               return -KEY_atan2;
4910             break;
4911         case 6:
4912             if (strEQ(d,"accept"))              return -KEY_accept;
4913             break;
4914         }
4915         break;
4916     case 'B':
4917         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4918         break;
4919     case 'b':
4920         if (strEQ(d,"bless"))                   return -KEY_bless;
4921         if (strEQ(d,"bind"))                    return -KEY_bind;
4922         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4923         break;
4924     case 'C':
4925         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4926         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
4927         break;
4928     case 'c':
4929         switch (len) {
4930         case 3:
4931             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4932             if (strEQ(d,"chr"))                 return -KEY_chr;
4933             if (strEQ(d,"cos"))                 return -KEY_cos;
4934             break;
4935         case 4:
4936             if (strEQ(d,"chop"))                return KEY_chop;
4937             break;
4938         case 5:
4939             if (strEQ(d,"close"))               return -KEY_close;
4940             if (strEQ(d,"chdir"))               return -KEY_chdir;
4941             if (strEQ(d,"chomp"))               return KEY_chomp;
4942             if (strEQ(d,"chmod"))               return -KEY_chmod;
4943             if (strEQ(d,"chown"))               return -KEY_chown;
4944             if (strEQ(d,"crypt"))               return -KEY_crypt;
4945             break;
4946         case 6:
4947             if (strEQ(d,"chroot"))              return -KEY_chroot;
4948             if (strEQ(d,"caller"))              return -KEY_caller;
4949             break;
4950         case 7:
4951             if (strEQ(d,"connect"))             return -KEY_connect;
4952             break;
4953         case 8:
4954             if (strEQ(d,"closedir"))            return -KEY_closedir;
4955             if (strEQ(d,"continue"))            return -KEY_continue;
4956             break;
4957         }
4958         break;
4959     case 'D':
4960         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4961         break;
4962     case 'd':
4963         switch (len) {
4964         case 2:
4965             if (strEQ(d,"do"))                  return KEY_do;
4966             break;
4967         case 3:
4968             if (strEQ(d,"die"))                 return -KEY_die;
4969             break;
4970         case 4:
4971             if (strEQ(d,"dump"))                return -KEY_dump;
4972             break;
4973         case 6:
4974             if (strEQ(d,"delete"))              return KEY_delete;
4975             break;
4976         case 7:
4977             if (strEQ(d,"defined"))             return KEY_defined;
4978             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4979             break;
4980         case 8:
4981             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4982             break;
4983         }
4984         break;
4985     case 'E':
4986         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4987         if (strEQ(d,"END"))                     return KEY_END;
4988         break;
4989     case 'e':
4990         switch (len) {
4991         case 2:
4992             if (strEQ(d,"eq"))                  return -KEY_eq;
4993             break;
4994         case 3:
4995             if (strEQ(d,"eof"))                 return -KEY_eof;
4996             if (strEQ(d,"exp"))                 return -KEY_exp;
4997             break;
4998         case 4:
4999             if (strEQ(d,"else"))                return KEY_else;
5000             if (strEQ(d,"exit"))                return -KEY_exit;
5001             if (strEQ(d,"eval"))                return KEY_eval;
5002             if (strEQ(d,"exec"))                return -KEY_exec;
5003             if (strEQ(d,"each"))                return KEY_each;
5004             break;
5005         case 5:
5006             if (strEQ(d,"elsif"))               return KEY_elsif;
5007             break;
5008         case 6:
5009             if (strEQ(d,"exists"))              return KEY_exists;
5010             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5011             break;
5012         case 8:
5013             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5014             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5015             break;
5016         case 9:
5017             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5018             break;
5019         case 10:
5020             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5021             if (strEQ(d,"endservent"))          return -KEY_endservent;
5022             break;
5023         case 11:
5024             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5025             break;
5026         }
5027         break;
5028     case 'f':
5029         switch (len) {
5030         case 3:
5031             if (strEQ(d,"for"))                 return KEY_for;
5032             break;
5033         case 4:
5034             if (strEQ(d,"fork"))                return -KEY_fork;
5035             break;
5036         case 5:
5037             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5038             if (strEQ(d,"flock"))               return -KEY_flock;
5039             break;
5040         case 6:
5041             if (strEQ(d,"format"))              return KEY_format;
5042             if (strEQ(d,"fileno"))              return -KEY_fileno;
5043             break;
5044         case 7:
5045             if (strEQ(d,"foreach"))             return KEY_foreach;
5046             break;
5047         case 8:
5048             if (strEQ(d,"formline"))            return -KEY_formline;
5049             break;
5050         }
5051         break;
5052     case 'G':
5053         if (len == 2) {
5054             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
5055             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
5056         }
5057         break;
5058     case 'g':
5059         if (strnEQ(d,"get",3)) {
5060             d += 3;
5061             if (*d == 'p') {
5062                 switch (len) {
5063                 case 7:
5064                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5065                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5066                     break;
5067                 case 8:
5068                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5069                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5070                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5071                     break;
5072                 case 11:
5073                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5074                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5075                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5076                     break;
5077                 case 14:
5078                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5079                     break;
5080                 case 16:
5081                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5082                     break;
5083                 }
5084             }
5085             else if (*d == 'h') {
5086                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5087                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5088                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5089             }
5090             else if (*d == 'n') {
5091                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5092                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5093                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5094             }
5095             else if (*d == 's') {
5096                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5097                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5098                 if (strEQ(d,"servent"))         return -KEY_getservent;
5099                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5100                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5101             }
5102             else if (*d == 'g') {
5103                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5104                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5105                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5106             }
5107             else if (*d == 'l') {
5108                 if (strEQ(d,"login"))           return -KEY_getlogin;
5109             }
5110             else if (strEQ(d,"c"))              return -KEY_getc;
5111             break;
5112         }
5113         switch (len) {
5114         case 2:
5115             if (strEQ(d,"gt"))                  return -KEY_gt;
5116             if (strEQ(d,"ge"))                  return -KEY_ge;
5117             break;
5118         case 4:
5119             if (strEQ(d,"grep"))                return KEY_grep;
5120             if (strEQ(d,"goto"))                return KEY_goto;
5121             if (strEQ(d,"glob"))                return KEY_glob;
5122             break;
5123         case 6:
5124             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5125             break;
5126         }
5127         break;
5128     case 'h':
5129         if (strEQ(d,"hex"))                     return -KEY_hex;
5130         break;
5131     case 'I':
5132         if (strEQ(d,"INIT"))                    return KEY_INIT;
5133         break;
5134     case 'i':
5135         switch (len) {
5136         case 2:
5137             if (strEQ(d,"if"))                  return KEY_if;
5138             break;
5139         case 3:
5140             if (strEQ(d,"int"))                 return -KEY_int;
5141             break;
5142         case 5:
5143             if (strEQ(d,"index"))               return -KEY_index;
5144             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5145             break;
5146         }
5147         break;
5148     case 'j':
5149         if (strEQ(d,"join"))                    return -KEY_join;
5150         break;
5151     case 'k':
5152         if (len == 4) {
5153             if (strEQ(d,"keys"))                return KEY_keys;
5154             if (strEQ(d,"kill"))                return -KEY_kill;
5155         }
5156         break;
5157     case 'L':
5158         if (len == 2) {
5159             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
5160             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
5161         }
5162         break;
5163     case 'l':
5164         switch (len) {
5165         case 2:
5166             if (strEQ(d,"lt"))                  return -KEY_lt;
5167             if (strEQ(d,"le"))                  return -KEY_le;
5168             if (strEQ(d,"lc"))                  return -KEY_lc;
5169             break;
5170         case 3:
5171             if (strEQ(d,"log"))                 return -KEY_log;
5172             break;
5173         case 4:
5174             if (strEQ(d,"last"))                return KEY_last;
5175             if (strEQ(d,"link"))                return -KEY_link;
5176             if (strEQ(d,"lock"))                return -KEY_lock;
5177             break;
5178         case 5:
5179             if (strEQ(d,"local"))               return KEY_local;
5180             if (strEQ(d,"lstat"))               return -KEY_lstat;
5181             break;
5182         case 6:
5183             if (strEQ(d,"length"))              return -KEY_length;
5184             if (strEQ(d,"listen"))              return -KEY_listen;
5185             break;
5186         case 7:
5187             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5188             break;
5189         case 9:
5190             if (strEQ(d,"localtime"))           return -KEY_localtime;
5191             break;
5192         }
5193         break;
5194     case 'm':
5195         switch (len) {
5196         case 1:                                 return KEY_m;
5197         case 2:
5198             if (strEQ(d,"my"))                  return KEY_my;
5199             break;
5200         case 3:
5201             if (strEQ(d,"map"))                 return KEY_map;
5202             break;
5203         case 5:
5204             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5205             break;
5206         case 6:
5207             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5208             if (strEQ(d,"msgget"))              return -KEY_msgget;
5209             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5210             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5211             break;
5212         }
5213         break;
5214     case 'N':
5215         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
5216         break;
5217     case 'n':
5218         if (strEQ(d,"next"))                    return KEY_next;
5219         if (strEQ(d,"ne"))                      return -KEY_ne;
5220         if (strEQ(d,"not"))                     return -KEY_not;
5221         if (strEQ(d,"no"))                      return KEY_no;
5222         break;
5223     case 'o':
5224         switch (len) {
5225         case 2:
5226             if (strEQ(d,"or"))                  return -KEY_or;
5227             break;
5228         case 3:
5229             if (strEQ(d,"ord"))                 return -KEY_ord;
5230             if (strEQ(d,"oct"))                 return -KEY_oct;
5231             if (strEQ(d,"our"))                 return KEY_our;
5232             break;
5233         case 4:
5234             if (strEQ(d,"open"))                return -KEY_open;
5235             break;
5236         case 7:
5237             if (strEQ(d,"opendir"))             return -KEY_opendir;
5238             break;
5239         }
5240         break;
5241     case 'p':
5242         switch (len) {
5243         case 3:
5244             if (strEQ(d,"pop"))                 return KEY_pop;
5245             if (strEQ(d,"pos"))                 return KEY_pos;
5246             break;
5247         case 4:
5248             if (strEQ(d,"push"))                return KEY_push;
5249             if (strEQ(d,"pack"))                return -KEY_pack;
5250             if (strEQ(d,"pipe"))                return -KEY_pipe;
5251             break;
5252         case 5:
5253             if (strEQ(d,"print"))               return KEY_print;
5254             break;
5255         case 6:
5256             if (strEQ(d,"printf"))              return KEY_printf;
5257             break;
5258         case 7:
5259             if (strEQ(d,"package"))             return KEY_package;
5260             break;
5261         case 9:
5262             if (strEQ(d,"prototype"))           return KEY_prototype;
5263         }
5264         break;
5265     case 'q':
5266         if (len <= 2) {
5267             if (strEQ(d,"q"))                   return KEY_q;
5268             if (strEQ(d,"qr"))                  return KEY_qr;
5269             if (strEQ(d,"qq"))                  return KEY_qq;
5270             if (strEQ(d,"qw"))                  return KEY_qw;
5271             if (strEQ(d,"qx"))                  return KEY_qx;
5272         }
5273         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5274         break;
5275     case 'r':
5276         switch (len) {
5277         case 3:
5278             if (strEQ(d,"ref"))                 return -KEY_ref;
5279             break;
5280         case 4:
5281             if (strEQ(d,"read"))                return -KEY_read;
5282             if (strEQ(d,"rand"))                return -KEY_rand;
5283             if (strEQ(d,"recv"))                return -KEY_recv;
5284             if (strEQ(d,"redo"))                return KEY_redo;
5285             break;
5286         case 5:
5287             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5288             if (strEQ(d,"reset"))               return -KEY_reset;
5289             break;
5290         case 6:
5291             if (strEQ(d,"return"))              return KEY_return;
5292             if (strEQ(d,"rename"))              return -KEY_rename;
5293             if (strEQ(d,"rindex"))              return -KEY_rindex;
5294             break;
5295         case 7:
5296             if (strEQ(d,"require"))             return -KEY_require;
5297             if (strEQ(d,"reverse"))             return -KEY_reverse;
5298             if (strEQ(d,"readdir"))             return -KEY_readdir;
5299             break;
5300         case 8:
5301             if (strEQ(d,"readlink"))            return -KEY_readlink;
5302             if (strEQ(d,"readline"))            return -KEY_readline;
5303             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5304             break;
5305         case 9:
5306             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5307             break;
5308         }
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 }