toke.c

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