toke.c

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