toke.c

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