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