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